RARTR0 ;HISC/GJC-Queue/Print Radiology Rpts utility routine. ; 06 Oct 2013 11:06 AM
;;5.0;Radiology/Nuclear Medicine;**8,26,74,84,99,1003,1005**;Nov 01, 2010;Build 13
; 06/28/2006 BAY/KAM Remedy Call 146291 - Change Patient Age to DOB
;
;Integration Agreements
;----------------------
;DT^DILF(2054); GETS^DIQ(2056); $$FMTE^XLFDT(10103); $$UP^XLFSTR(10104); ^DIWP(10011)
;NEW PERSON file read w/FM (10060)
;
EN1 ; Called from RARTR ;P84 GETS^DIQ added...
S RARPT(0)=$G(^RARPT(+$G(RARPT),0)) Q:RARPT(0)']""
S RARPT(10)=$P(RARPT(0),"^",10)
S RAVERF=+$P(RARPT(0),U,9),RAPVERF=+$P(RARPT(0),U,13)
K RAPIR,RAPIS S RAPIR=+$P(RALB,"^",12),RAPIS=+$P(RALB,"^",15)
;format of the RAPIR/RAPIS arrays: P84 logic
;RAPI*=IEN file 200
;RAPI*(200,RAPI*,.01)= NAME (required)
;RAPI*(200,RAPI*,20.2) = SIGNATURE BLOCK PRINTED NAME (if any)
;RAPI*(200,RAPI*,20.3) = SIGNATURE BLOCK TITLE (if any)
I RAPIR D GETS^DIQ(200,RAPIR,".01;20.2;20.3","","RAPIR") S RAPIR("IENS")=RAPIR_","
I RAPIS D GETS^DIQ(200,RAPIS,".01;20.2;20.3","","RAPIS") S RAPIS("IENS")=RAPIS_","
S RAWHOVER=+$P(RARPT(0),"^",17)
I RAVERF,((RAPIR=RAVERF)!(RAPIS=RAVERF)) D
. S RAVERFND="" ; Set verifier found flag
. Q
I RAPIS D Q:$D(RAOOUT)
. ;get signature block name if defined
. S RALBS=$E(RAPIS(200,RAPIS("IENS"),20.2),1,25)
. S:RALBS="" RALBS=$E(RAPIS(200,RAPIS("IENS"),.01),1,25) ;default to NAME
. ;
. ;get signature block title if defined
. S RALBST=$G(RAPIS(200,RAPIS("IENS"),20.3)) ; max: 50 chars
. S:RALBST="" RALBST=$$TITLE^RARTR0(RAPIS)
. ;
. I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT)
. I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL
. I '$D(RAUTOE) D
.. W !,"Primary Interpreting Staff:",!?2,$S(RALBS]"":RALBS,1:"Unknown")
.. W:$L(RALBST) ", "_$E(RALBST,1,((IOM-$X)-16))
.. ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING
.. Q
. E D
.. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Staff:"
.. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RALBS]"":RALBS,1:"Unknown")
.. Q:'$L(RALBST) N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT))
.. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBST,1,((80-RALEN)-16))
.. Q
. I $D(RAVERFND)&(RAPIS=RAVERF),(RAPIS(200,RAPIS("IENS"),.01)'="RADIOLOGY,OUTSIDE SERVICE") D
.. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q
... W:RAWHOVER=RAPIS !?10,"(Verifier, no e-sig)"
... ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist
... ;Other verifier may not be a transcriptionist
... ;W:RAWHOVER'=RAPIS !?10,"Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D."
... W:RAWHOVER'=RAPIS !?5,"Verified by ",$$GET1^DIQ(200,+RAWHOVER,.01)," for "_RALBS ;Removed RA*5*8 _", M.D."
... ;End Patch
... Q
.. I $G(RARPT(10))']"",($D(RAUTOE)) D Q
... S:RAWHOVER=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)"
... ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist
... ;Other verifier may not be a transcriptionist
... ;S:RAWHOVER'=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D."
... S:RAWHOVER'=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by "_$$GET1^DIQ(200,+RAWHOVER,.01)_" for "_RALBS ;Removed RA*5*8 _", M.D."
... ;End Patch
... Q
.. W:'$D(RAUTOE) " (Verifier)"
.. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)"
.. Q
. I RAPIS=RAPVERF,'$D(RAUTOE) W " (Pre-Verifier)"
. I RAPIS=RAPVERF,$D(RAUTOE) S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)"
. Q
D SECSTF^RARTR1 Q:$D(RAOOUT) ; Print secondary interp'ting staff now
;now for primary resident definitions...
I RAPIR D Q:$D(RAOOUT)
. ;get signature block name if defined
. S RALBR=$E(RAPIR(200,RAPIR("IENS"),20.2),1,25)
. S:RALBR="" RALBR=$E(RAPIR(200,RAPIR("IENS"),.01),1,25) ;default to NAME
. ;
. ;get signature block title if defined
. S RALBRT=$G(RAPIR(200,RAPIR("IENS"),20.3)) ; max: 50 chars
. S:RALBRT="" RALBRT=$$TITLE^RARTR0(RAPIR)
. ;
. I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT)
. I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL
. I '$D(RAUTOE) D
.. W !,"Primary Interpreting Resident:",!?2,$S(RALBR]"":RALBR,1:"Unknown")
.. W:$L(RALBRT) ", "_$E(RALBRT,1,((IOM-$X)-16))
.. Q
. I $D(RAUTOE) D
.. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Resident:"
.. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RALBR]"":RALBR,1:"Unknown")
.. Q:'$L(RALBRT) N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT))
.. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBRT,1,((80-RALEN)-16))
.. Q
. I $D(RAVERFND)&(RAPIR=RAVERF) D
.. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q
... W:RAWHOVER=RAPIR !?10,"(Verifier, no e-sig)"
... ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist
... ;Other verifier may not be a transcriptionist
... ;W:RAWHOVER'=RAPIR !?10,"Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D."
... W:RAWHOVER'=RAPIR !?5,"Verified by ",$$GET1^DIQ(200,+RAWHOVER,.01)," for "_RALBR ;Removed RA*5*8 _", M.D."
... ;End Patch
... Q
.. I $G(RARPT(10))']"",($D(RAUTOE)) D Q
... S:RAWHOVER=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)"
... ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist
... ;Other verifier may not be a transcriptionist
... ;S:RAWHOVER'=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D."
... S:RAWHOVER'=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by "_$$GET1^DIQ(200,+RAWHOVER,.01)_" for "_RALBR ;Removed RA*5*8 _", M.D."
... ;End Patch
... Q
.. W:'$D(RAUTOE) " (Verifier)"
.. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)"
.. Q
. I RAPIR=RAPVERF,('$D(RAUTOE)) W " (Pre-Verifier)"
. I RAPIR=RAPVERF,($D(RAUTOE)) S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)"
. Q
D SECRES^RARTR1 ; Print out secondary interp'ting resident now
K RAPIR,RAPIS ;P84 kills added
Q
;
TITLE(X) ;Return the radiology classification in lieu of the signature block title
; 'X' is the IEN of the Primary Interpreting Resident i.e, ^DD(70.03,12
; -OR-
; 'X' is the IEN of the Primary Interpreting Staff i.e, ^DD(70.03,15
Q $S($D(^VA(200,"ARC","R",X)):"Resident Physician",$D(^VA(200,"ARC","S",X)):"Staff Physician",1:"")
;
HEAD ; Set up header info for e-mail message (called from INIT^RARTR)
; 06/28/2006 BAY/KAM Remedy Call 146291 Change Patient Age to DOB
N RAGE,RATPHY,RACSE,RAILOC,RANME,RAPRIPHY,RAPTLOC,RAREQPHY,RASERV,RASEX,RADOB
N RASPACE,RASSN,X1,X2 S:'$D(RAACNT) RAACNT=0
;Added next line for Remedy Call 146291
D DT^DILF("E",$P(RAY0,"^",3),.RADOB) ;Get Date of Birth/External Fmt
;
S RANME=$P(RAY0,"^"),RASSN=$P(RAY0,"^",9)
S RASEX=$$UP^XLFSTR($P(RAY0,"^",2))
S RACSE=$P($G(^RARPT(RARPT,0)),"^")_"@"_$P($$FMTE^XLFDT($P(RAY2,"^")),"@",2)
; Remedy Call 146291 Removed line calculating age
S RAREQPHY=$$XTERNAL^RAUTL5($P(RAY3,"^",14),$P($G(^DD(70.03,14,0)),"^",2))
S RAPTLOC=$$PTLOC^RAUTL12() S:RAREQPHY']"" RAREQPHY="Unknown"
S RASERV=$$XTERNAL^RAUTL5($P(RAY3,"^",7),$P($G(^DD(70.03,7,0)),"^",2))
S RATPHY=$$ATND^RAUTL5(RADFN,DT),RAPRIPHY=$$PRIM^RAUTL5(RADFN,DT)
S RAILOC=$$XTERNAL^RAUTL5($P(RAY2,"^",4),$P($G(^DD(70.02,4,0)),"^",2))
S:RAILOC']"" RAILOC="Unknown" S:RASERV']"" RASERV="Unknown"
S RANME=$E(RANME,1,20)_" "
;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler 2003 patch
;Use standard call for SSN, and remove SSN formatting
;S RASSN=$E(RASSN,1,3)_"-"_$E(RASSN,4,5)_"-"_$E(RASSN,6,9)_" "
S RASSN=$$SSN^RAUTL,RASSN=RASSN_" "
;End Patch
; Remedy Call 146291 Changed next line to use RADOB(0)
S RAGE="DOB-"_$G(RADOB(0))_" "_$S(RASEX="F":"F",RASEX="M":"M",1:"UNK")
S $P(RASPACE," ",(22-$L(RAGE)))=""
S RAGE=RAGE_RASPACE,RACSE="Case: "_RACSE
S RAREQPHY="Req Phys: "_$E(RAREQPHY,1,28)
S RASPACE="",$P(RASPACE," ",(42-$L(RAREQPHY)))=""
S RAREQPHY=RAREQPHY_RASPACE
S RAPTLOC="Pat Loc: "_$S(RAPTLOC]"":$E(RAPTLOC,1,30),1:"Unknown")
S RATPHY="Att Phys: "_$E(RATPHY,1,28)
S RASPACE="",$P(RASPACE," ",(42-$L(RATPHY)))=""
S RATPHY=RATPHY_RASPACE
S RAILOC="Img Loc: "_$E(RAILOC,1,30)
S RAPRIPHY="Pri Phys: "_$E(RAPRIPHY,1,28)
S RASPACE="",$P(RASPACE," ",(42-$L(RAPRIPHY)))=""
S RAPRIPHY=RAPRIPHY_RASPACE
S RASERV="Service: "_$E(RASERV,1,30)
S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RANME_RASSN_RAGE_RACSE
S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAREQPHY_RAPTLOC
S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RATPHY_RAILOC
S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAPRIPHY_RASERV
;p99: get pt sex, add pregnancy screen and pregnancy screen comment
;
;IHS/BJI/DAY - Patch 1005 - Gender Fix
;I $$PTSEX^RAUTL8(RADFN)="F",$D(RAY3) D
I $$PTSEX^RAUTL8(RADFN)'="M",$D(RAY3) D
.;
.Q:RAY3<0
.N RAPCOMM,RA32PSC,DIWF,DIWL,DIWR,X S RAPCOMM=$G(^RADPT(RADFN,"DT",+$G(RADTI),"P",+$G(RACNI),"PCOMM"))
.S:$P(RAY3,U,32)'="" ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Pregnancy Screen: "_$S($P(RAY3,"^",32)="y":"Patient answered yes",$P(RAY3,"^",32)="n":"Patient answered no",$P(RAY3,"^",32)="u":"Patient is unable to answer or is unsure",1:"")
.I ($P(RAY3,U,32)'="n"),$L(RAPCOMM) D
..S DIWF="",DIWL=3,DIWR=75,X="Pregnancy Screen Comment: "_RAPCOMM K ^UTILITY($J,"W") D ^DIWP
..F RA32PSC=0:0 S RA32PSC=$O(^UTILITY($J,"W",3,RA32PSC)) Q:RA32PSC'>0 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=^UTILITY($J,"W",3,RA32PSC,0)
..K ^UTILITY($J,"W")
S:$D(RAERRFLG) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2()
S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
Q
RARTR0 ;HISC/GJC-Queue/Print Radiology Rpts utility routine. ; 06 Oct 2013 11:06 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**8,26,74,84,99,1003,1005**;Nov 01, 2010;Build 13
+2 ; 06/28/2006 BAY/KAM Remedy Call 146291 - Change Patient Age to DOB
+3 ;
+4 ;Integration Agreements
+5 ;----------------------
+6 ;DT^DILF(2054); GETS^DIQ(2056); $$FMTE^XLFDT(10103); $$UP^XLFSTR(10104); ^DIWP(10011)
+7 ;NEW PERSON file read w/FM (10060)
+8 ;
EN1 ; Called from RARTR ;P84 GETS^DIQ added...
+1 SET RARPT(0)=$GET(^RARPT(+$GET(RARPT),0))
IF RARPT(0)']""
QUIT
+2 SET RARPT(10)=$PIECE(RARPT(0),"^",10)
+3 SET RAVERF=+$PIECE(RARPT(0),U,9)
SET RAPVERF=+$PIECE(RARPT(0),U,13)
+4 KILL RAPIR,RAPIS
SET RAPIR=+$PIECE(RALB,"^",12)
SET RAPIS=+$PIECE(RALB,"^",15)
+5 ;format of the RAPIR/RAPIS arrays: P84 logic
+6 ;RAPI*=IEN file 200
+7 ;RAPI*(200,RAPI*,.01)= NAME (required)
+8 ;RAPI*(200,RAPI*,20.2) = SIGNATURE BLOCK PRINTED NAME (if any)
+9 ;RAPI*(200,RAPI*,20.3) = SIGNATURE BLOCK TITLE (if any)
+10 IF RAPIR
DO GETS^DIQ(200,RAPIR,".01;20.2;20.3","","RAPIR")
SET RAPIR("IENS")=RAPIR_","
+11 IF RAPIS
DO GETS^DIQ(200,RAPIS,".01;20.2;20.3","","RAPIS")
SET RAPIS("IENS")=RAPIS_","
+12 SET RAWHOVER=+$PIECE(RARPT(0),"^",17)
+13 IF RAVERF
IF ((RAPIR=RAVERF)!(RAPIS=RAVERF))
Begin DoDot:1
+14 ; Set verifier found flag
SET RAVERFND=""
+15 QUIT
End DoDot:1
+16 IF RAPIS
Begin DoDot:1
+17 ;get signature block name if defined
+18 SET RALBS=$EXTRACT(RAPIS(200,RAPIS("IENS"),20.2),1,25)
+19 ;default to NAME
IF RALBS=""
SET RALBS=$EXTRACT(RAPIS(200,RAPIS("IENS"),.01),1,25)
+20 ;
+21 ;get signature block title if defined
+22 ; max: 50 chars
SET RALBST=$GET(RAPIS(200,RAPIS("IENS"),20.3))
+23 IF RALBST=""
SET RALBST=$$TITLE^RARTR0(RAPIS)
+24 ;
+25 IF '$DATA(RAUTOE)
IF ($Y+RAFOOT+4)>IOSL
DO HANG^RARTR2
IF $DATA(RAOOUT)
QUIT
+26 IF '$DATA(RAUTOE)
IF ($Y+RAFOOT+4)>IOSL
DO HD^RARTR
+27 IF '$DATA(RAUTOE)
Begin DoDot:2
+28 WRITE !,"Primary Interpreting Staff:",!?2,$SELECT(RALBS]"":RALBS,1:"Unknown")
+29 IF $LENGTH(RALBST)
WRITE ", "_$EXTRACT(RALBST,1,((IOM-$X)-16))
+30 ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING
+31 QUIT
End DoDot:2
+32 IF '$TEST
Begin DoDot:2
+33 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Staff:"
+34 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$SELECT(RALBS]"":RALBS,1:"Unknown")
+35 IF '$LENGTH(RALBST)
QUIT
NEW RALEN
SET RALEN=$LENGTH(^TMP($JOB,"RA AUTOE",RAACNT))
+36 SET ^TMP($JOB,"RA AUTOE",RAACNT)=^TMP($JOB,"RA AUTOE",RAACNT)_", "_$EXTRACT(RALBST,1,((80-RALEN)-16))
+37 QUIT
End DoDot:2
+38 IF $DATA(RAVERFND)&(RAPIS=RAVERF)
IF (RAPIS(200,RAPIS("IENS"),.01)'="RADIOLOGY,OUTSIDE SERVICE")
Begin DoDot:2
+39 IF $GET(RARPT(10))']""
IF ('$DATA(RAUTOE))
Begin DoDot:3
+40 IF RAWHOVER=RAPIS
WRITE !?10,"(Verifier, no e-sig)"
+41 ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist
+42 ;Other verifier may not be a transcriptionist
+43 ;W:RAWHOVER'=RAPIS !?10,"Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D."
+44 ;Removed RA*5*8 _", M.D."
IF RAWHOVER'=RAPIS
WRITE !?5,"Verified by ",$$GET1^DIQ(200,+RAWHOVER,.01)," for "_RALBS
+45 ;End Patch
+46 QUIT
End DoDot:3
QUIT
+47 IF $GET(RARPT(10))']""
IF ($DATA(RAUTOE))
Begin DoDot:3
+48 IF RAWHOVER=RAPIS
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)"
+49 ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist
+50 ;Other verifier may not be a transcriptionist
+51 ;S:RAWHOVER'=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D."
+52 ;Removed RA*5*8 _", M.D."
IF RAWHOVER'=RAPIS
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by "_$$GET1^DIQ(200,+RAWHOVER,.01)_" for "_RALBS
+53 ;End Patch
+54 QUIT
End DoDot:3
QUIT
+55 IF '$DATA(RAUTOE)
WRITE " (Verifier)"
+56 IF $DATA(RAUTOE)
SET ^TMP($JOB,"RA AUTOE",RAACNT)=^TMP($JOB,"RA AUTOE",RAACNT)_" (Verifier)"
+57 QUIT
End DoDot:2
+58 IF RAPIS=RAPVERF
IF '$DATA(RAUTOE)
WRITE " (Pre-Verifier)"
+59 IF RAPIS=RAPVERF
IF $DATA(RAUTOE)
SET ^TMP($JOB,"RA AUTOE",RAACNT)=^TMP($JOB,"RA AUTOE",RAACNT)_" (Pre-Verifier)"
+60 QUIT
End DoDot:1
IF $DATA(RAOOUT)
QUIT
+61 ; Print secondary interp'ting staff now
DO SECSTF^RARTR1
IF $DATA(RAOOUT)
QUIT
+62 ;now for primary resident definitions...
+63 IF RAPIR
Begin DoDot:1
+64 ;get signature block name if defined
+65 SET RALBR=$EXTRACT(RAPIR(200,RAPIR("IENS"),20.2),1,25)
+66 ;default to NAME
IF RALBR=""
SET RALBR=$EXTRACT(RAPIR(200,RAPIR("IENS"),.01),1,25)
+67 ;
+68 ;get signature block title if defined
+69 ; max: 50 chars
SET RALBRT=$GET(RAPIR(200,RAPIR("IENS"),20.3))
+70 IF RALBRT=""
SET RALBRT=$$TITLE^RARTR0(RAPIR)
+71 ;
+72 IF '$DATA(RAUTOE)
IF ($Y+RAFOOT+4)>IOSL
DO HANG^RARTR2
IF $DATA(RAOOUT)
QUIT
+73 IF '$DATA(RAUTOE)
IF ($Y+RAFOOT+4)>IOSL
DO HD^RARTR
+74 IF '$DATA(RAUTOE)
Begin DoDot:2
+75 WRITE !,"Primary Interpreting Resident:",!?2,$SELECT(RALBR]"":RALBR,1:"Unknown")
+76 IF $LENGTH(RALBRT)
WRITE ", "_$EXTRACT(RALBRT,1,((IOM-$X)-16))
+77 QUIT
End DoDot:2
+78 IF $DATA(RAUTOE)
Begin DoDot:2
+79 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Resident:"
+80 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$SELECT(RALBR]"":RALBR,1:"Unknown")
+81 IF '$LENGTH(RALBRT)
QUIT
NEW RALEN
SET RALEN=$LENGTH(^TMP($JOB,"RA AUTOE",RAACNT))
+82 SET ^TMP($JOB,"RA AUTOE",RAACNT)=^TMP($JOB,"RA AUTOE",RAACNT)_", "_$EXTRACT(RALBRT,1,((80-RALEN)-16))
+83 QUIT
End DoDot:2
+84 IF $DATA(RAVERFND)&(RAPIR=RAVERF)
Begin DoDot:2
+85 IF $GET(RARPT(10))']""
IF ('$DATA(RAUTOE))
Begin DoDot:3
+86 IF RAWHOVER=RAPIR
WRITE !?10,"(Verifier, no e-sig)"
+87 ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist
+88 ;Other verifier may not be a transcriptionist
+89 ;W:RAWHOVER'=RAPIR !?10,"Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D."
+90 ;Removed RA*5*8 _", M.D."
IF RAWHOVER'=RAPIR
WRITE !?5,"Verified by ",$$GET1^DIQ(200,+RAWHOVER,.01)," for "_RALBR
+91 ;End Patch
+92 QUIT
End DoDot:3
QUIT
+93 IF $GET(RARPT(10))']""
IF ($DATA(RAUTOE))
Begin DoDot:3
+94 IF RAWHOVER=RAPIR
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)"
+95 ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist
+96 ;Other verifier may not be a transcriptionist
+97 ;S:RAWHOVER'=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D."
+98 ;Removed RA*5*8 _", M.D."
IF RAWHOVER'=RAPIR
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by "_$$GET1^DIQ(200,+RAWHOVER,.01)_" for "_RALBR
+99 ;End Patch
+100 QUIT
End DoDot:3
QUIT
+101 IF '$DATA(RAUTOE)
WRITE " (Verifier)"
+102 IF $DATA(RAUTOE)
SET ^TMP($JOB,"RA AUTOE",RAACNT)=^TMP($JOB,"RA AUTOE",RAACNT)_" (Verifier)"
+103 QUIT
End DoDot:2
+104 IF RAPIR=RAPVERF
IF ('$DATA(RAUTOE))
WRITE " (Pre-Verifier)"
+105 IF RAPIR=RAPVERF
IF ($DATA(RAUTOE))
SET ^TMP($JOB,"RA AUTOE",RAACNT)=^TMP($JOB,"RA AUTOE",RAACNT)_" (Pre-Verifier)"
+106 QUIT
End DoDot:1
IF $DATA(RAOOUT)
QUIT
+107 ; Print out secondary interp'ting resident now
DO SECRES^RARTR1
+108 ;P84 kills added
KILL RAPIR,RAPIS
+109 QUIT
+110 ;
TITLE(X) ;Return the radiology classification in lieu of the signature block title
+1 ; 'X' is the IEN of the Primary Interpreting Resident i.e, ^DD(70.03,12
+2 ; -OR-
+3 ; 'X' is the IEN of the Primary Interpreting Staff i.e, ^DD(70.03,15
+4 QUIT $SELECT($DATA(^VA(200,"ARC","R",X)):"Resident Physician",$DATA(^VA(200,"ARC","S",X)):"Staff Physician",1:"")
+5 ;
HEAD ; Set up header info for e-mail message (called from INIT^RARTR)
+1 ; 06/28/2006 BAY/KAM Remedy Call 146291 Change Patient Age to DOB
+2 NEW RAGE,RATPHY,RACSE,RAILOC,RANME,RAPRIPHY,RAPTLOC,RAREQPHY,RASERV,RASEX,RADOB
+3 NEW RASPACE,RASSN,X1,X2
IF '$DATA(RAACNT)
SET RAACNT=0
+4 ;Added next line for Remedy Call 146291
+5 ;Get Date of Birth/External Fmt
DO DT^DILF("E",$PIECE(RAY0,"^",3),.RADOB)
+6 ;
+7 SET RANME=$PIECE(RAY0,"^")
SET RASSN=$PIECE(RAY0,"^",9)
+8 SET RASEX=$$UP^XLFSTR($PIECE(RAY0,"^",2))
+9 SET RACSE=$PIECE($GET(^RARPT(RARPT,0)),"^")_"@"_$PIECE($$FMTE^XLFDT($PIECE(RAY2,"^")),"@",2)
+10 ; Remedy Call 146291 Removed line calculating age
+11 SET RAREQPHY=$$XTERNAL^RAUTL5($PIECE(RAY3,"^",14),$PIECE($GET(^DD(70.03,14,0)),"^",2))
+12 SET RAPTLOC=$$PTLOC^RAUTL12()
IF RAREQPHY']""
SET RAREQPHY="Unknown"
+13 SET RASERV=$$XTERNAL^RAUTL5($PIECE(RAY3,"^",7),$PIECE($GET(^DD(70.03,7,0)),"^",2))
+14 SET RATPHY=$$ATND^RAUTL5(RADFN,DT)
SET RAPRIPHY=$$PRIM^RAUTL5(RADFN,DT)
+15 SET RAILOC=$$XTERNAL^RAUTL5($PIECE(RAY2,"^",4),$PIECE($GET(^DD(70.02,4,0)),"^",2))
+16 IF RAILOC']""
SET RAILOC="Unknown"
IF RASERV']""
SET RASERV="Unknown"
+17 SET RANME=$EXTRACT(RANME,1,20)_" "
+18 ;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler 2003 patch
+19 ;Use standard call for SSN, and remove SSN formatting
+20 ;S RASSN=$E(RASSN,1,3)_"-"_$E(RASSN,4,5)_"-"_$E(RASSN,6,9)_" "
+21 SET RASSN=$$SSN^RAUTL
SET RASSN=RASSN_" "
+22 ;End Patch
+23 ; Remedy Call 146291 Changed next line to use RADOB(0)
+24 SET RAGE="DOB-"_$GET(RADOB(0))_" "_$SELECT(RASEX="F":"F",RASEX="M":"M",1:"UNK")
+25 SET $PIECE(RASPACE," ",(22-$LENGTH(RAGE)))=""
+26 SET RAGE=RAGE_RASPACE
SET RACSE="Case: "_RACSE
+27 SET RAREQPHY="Req Phys: "_$EXTRACT(RAREQPHY,1,28)
+28 SET RASPACE=""
SET $PIECE(RASPACE," ",(42-$LENGTH(RAREQPHY)))=""
+29 SET RAREQPHY=RAREQPHY_RASPACE
+30 SET RAPTLOC="Pat Loc: "_$SELECT(RAPTLOC]"":$EXTRACT(RAPTLOC,1,30),1:"Unknown")
+31 SET RATPHY="Att Phys: "_$EXTRACT(RATPHY,1,28)
+32 SET RASPACE=""
SET $PIECE(RASPACE," ",(42-$LENGTH(RATPHY)))=""
+33 SET RATPHY=RATPHY_RASPACE
+34 SET RAILOC="Img Loc: "_$EXTRACT(RAILOC,1,30)
+35 SET RAPRIPHY="Pri Phys: "_$EXTRACT(RAPRIPHY,1,28)
+36 SET RASPACE=""
SET $PIECE(RASPACE," ",(42-$LENGTH(RAPRIPHY)))=""
+37 SET RAPRIPHY=RAPRIPHY_RASPACE
+38 SET RASERV="Service: "_$EXTRACT(RASERV,1,30)
+39 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RANME_RASSN_RAGE_RACSE
+40 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAREQPHY_RAPTLOC
+41 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RATPHY_RAILOC
+42 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAPRIPHY_RASERV
+43 ;p99: get pt sex, add pregnancy screen and pregnancy screen comment
+44 ;
+45 ;IHS/BJI/DAY - Patch 1005 - Gender Fix
+46 ;I $$PTSEX^RAUTL8(RADFN)="F",$D(RAY3) D
+47 IF $$PTSEX^RAUTL8(RADFN)'="M"
IF $DATA(RAY3)
Begin DoDot:1
+48 ;
+49 IF RAY3<0
QUIT
+50 NEW RAPCOMM,RA32PSC,DIWF,DIWL,DIWR,X
SET RAPCOMM=$GET(^RADPT(RADFN,"DT",+$GET(RADTI),"P",+$GET(RACNI),"PCOMM"))
+51 IF $PIECE(RAY3,U,32)'=""
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Pregnancy Screen: "_$SELECT($PIECE(RAY3,"^",32)="y":"Patient answered yes",$PIECE(RAY3,"^",32)="n":"Patient answered no",$PIECE(RAY3,"^",32)="u":"Patient is unable to answer or is
unsure",1:"")
+52 IF ($PIECE(RAY3,U,32)'="n")
IF $LENGTH(RAPCOMM)
Begin DoDot:2
+53 SET DIWF=""
SET DIWL=3
SET DIWR=75
SET X="Pregnancy Screen Comment: "_RAPCOMM
KILL ^UTILITY($JOB,"W")
DO ^DIWP
+54 FOR RA32PSC=0:0
SET RA32PSC=$ORDER(^UTILITY($JOB,"W",3,RA32PSC))
IF RA32PSC'>0
QUIT
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=^UTILITY($JOB,"W",3,RA32PSC,0)
+55 KILL ^UTILITY($JOB,"W")
End DoDot:2
End DoDot:1
+56 IF $DATA(RAERRFLG)
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2()
+57 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
+58 QUIT
