RARTR0 ;HISC/GJC - Queue/Print Radiology Rpts utility routine. ; May 23, 2024@14:02:42
;;5.0;Radiology/Nuclear Medicine;**8,26,74,84,99,210,216**;Mar 16, 1998;Build 2
; 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)
;$$NAME^XUAF4,$$MADD^XUAF4(2171)
;
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)"
... W:RAWHOVER'=RAPIS !?10,"Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D."
... Q
.. I $G(RARPT(10))']"",($D(RAUTOE)) D Q
... S:RAWHOVER=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)"
... S:RAWHOVER'=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D."
... 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)"
... W:RAWHOVER'=RAPIR !?10,"Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D."
... Q
.. I $G(RARPT(10))']"",($D(RAUTOE)) D Q
... S:RAWHOVER=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)"
... S:RAWHOVER'=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D."
... 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)_" "
S RASSN=$E(RASSN,1,3)_"-"_$E(RASSN,4,5)_"-"_$E(RASSN,6,9)_" "
; 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
I $$PTSEX^RAUTL8(RADFN)="F",$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))=""
;p210/KLM - add to CPRS report if not an outside report or no credit location
N RADIVDA,RACRM S RADIVDA=$P(^RADPT(RADFN,"DT",RADTI,0),U,3),RACRM=$P($G(^RA(79.1,$P(^RADPT(RADFN,"DT",RADTI,0),U,4),0)),U,21)
I $G(RAST)'="EF",($G(RACRM)'=2) D HDRFAC(RADIVDA) ;p216/KLM - add $G ^ for i-loc lookup (site deleted i-loc)
Q
HDRFAC(RADIVDA) ;p210/KLM - Add Facility Contact Data for FDA mammography requirement
Q:RADIVDA="" ;no division passed
N RAMADDR,RACSZ,RAFACN,RAPHONE,RAIENDIV,RACNTR,RACOL S RACNTR=40
S RAPHONE=$$GET1^DIQ(79,RADIVDA,200) ;new field - facility phone number
S RAFACN=$P($$NAME^XUAF4(RADIVDA),U),RAMADDR=$$PADD^XUAF4(RADIVDA) ;p216 - get physical address, not mailing address
I $P(RAMADDR,U,2)="" S RAMADDR=$$MADD^XUAF4(RADIVDA) ;p216 - check mailing if no physical
S RACSZ=$P(RAMADDR,U,2)_", "_$P(RAMADDR,U,3)_" "_$P($P(RAMADDR,U,4),"-")
I $D(RAUTOE) D Q
.S RASPACE="",RACNTR=45
.S $P(RASPACE," ",(RACNTR-($L(RAFACN)/2)))="" S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPACE_RAFACN
.S $P(RASPACE," ",(RACNTR-($L(RACSZ)/2)))="" S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPACE_RACSZ
.S $P(RASPACE," ",(RACNTR-($L(RAPHONE)/2)))="" S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPACE_RAPHONE
.Q
S RACOL=RACNTR-($L(RAFACN)/2) W !,?RACOL,RAFACN
S RACOL=RACNTR-($L(RACSZ)/2) W !,?RACOL,RACSZ
S RACOL=RACNTR-($L(RAPHONE)/2) W !,?RACOL,RAPHONE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARTR0 9933 printed Dec 13, 2024@02:39:27 Page 2
RARTR0 ;HISC/GJC - Queue/Print Radiology Rpts utility routine. ; May 23, 2024@14:02:42
+1 ;;5.0;Radiology/Nuclear Medicine;**8,26,74,84,99,210,216**;Mar 16, 1998;Build 2
+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 ;$$NAME^XUAF4,$$MADD^XUAF4(2171)
+9 ;
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 ;Removed RA*5*8 _", M.D."
if RAWHOVER'=RAPIS
WRITE !?10,"Verified by transcriptionist for "_RALBS
+42 QUIT
End DoDot:3
QUIT
+43 IF $GET(RARPT(10))']""
IF ($DATA(RAUTOE))
Begin DoDot:3
+44 if RAWHOVER=RAPIS
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)"
+45 ;Removed RA*5*8 _", M.D."
if RAWHOVER'=RAPIS
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBS
+46 QUIT
End DoDot:3
QUIT
+47 if '$DATA(RAUTOE)
WRITE " (Verifier)"
+48 if $DATA(RAUTOE)
SET ^TMP($JOB,"RA AUTOE",RAACNT)=^TMP($JOB,"RA AUTOE",RAACNT)_" (Verifier)"
+49 QUIT
End DoDot:2
+50 IF RAPIS=RAPVERF
IF '$DATA(RAUTOE)
WRITE " (Pre-Verifier)"
+51 IF RAPIS=RAPVERF
IF $DATA(RAUTOE)
SET ^TMP($JOB,"RA AUTOE",RAACNT)=^TMP($JOB,"RA AUTOE",RAACNT)_" (Pre-Verifier)"
+52 QUIT
End DoDot:1
if $DATA(RAOOUT)
QUIT
+53 ; Print secondary interp'ting staff now
DO SECSTF^RARTR1
if $DATA(RAOOUT)
QUIT
+54 ;now for primary resident definitions...
+55 IF RAPIR
Begin DoDot:1
+56 ;get signature block name if defined
+57 SET RALBR=$EXTRACT(RAPIR(200,RAPIR("IENS"),20.2),1,25)
+58 ;default to NAME
if RALBR=""
SET RALBR=$EXTRACT(RAPIR(200,RAPIR("IENS"),.01),1,25)
+59 ;
+60 ;get signature block title if defined
+61 ; max: 50 chars
SET RALBRT=$GET(RAPIR(200,RAPIR("IENS"),20.3))
+62 if RALBRT=""
SET RALBRT=$$TITLE^RARTR0(RAPIR)
+63 ;
+64 IF '$DATA(RAUTOE)
if ($Y+RAFOOT+4)>IOSL
DO HANG^RARTR2
if $DATA(RAOOUT)
QUIT
+65 IF '$DATA(RAUTOE)
if ($Y+RAFOOT+4)>IOSL
DO HD^RARTR
+66 IF '$DATA(RAUTOE)
Begin DoDot:2
+67 WRITE !,"Primary Interpreting Resident:",!?2,$SELECT(RALBR]"":RALBR,1:"Unknown")
+68 if $LENGTH(RALBRT)
WRITE ", "_$EXTRACT(RALBRT,1,((IOM-$X)-16))
+69 QUIT
End DoDot:2
+70 IF $DATA(RAUTOE)
Begin DoDot:2
+71 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Resident:"
+72 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$SELECT(RALBR]"":RALBR,1:"Unknown")
+73 if '$LENGTH(RALBRT)
QUIT
NEW RALEN
SET RALEN=$LENGTH(^TMP($JOB,"RA AUTOE",RAACNT))
+74 SET ^TMP($JOB,"RA AUTOE",RAACNT)=^TMP($JOB,"RA AUTOE",RAACNT)_", "_$EXTRACT(RALBRT,1,((80-RALEN)-16))
+75 QUIT
End DoDot:2
+76 IF $DATA(RAVERFND)&(RAPIR=RAVERF)
Begin DoDot:2
+77 IF $GET(RARPT(10))']""
IF ('$DATA(RAUTOE))
Begin DoDot:3
+78 if RAWHOVER=RAPIR
WRITE !?10,"(Verifier, no e-sig)"
+79 ;Removed RA*5*8 _", M.D."
if RAWHOVER'=RAPIR
WRITE !?10,"Verified by transcriptionist for "_RALBR
+80 QUIT
End DoDot:3
QUIT
+81 IF $GET(RARPT(10))']""
IF ($DATA(RAUTOE))
Begin DoDot:3
+82 if RAWHOVER=RAPIR
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)"
+83 ;Removed RA*5*8 _", M.D."
if RAWHOVER'=RAPIR
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBR
+84 QUIT
End DoDot:3
QUIT
+85 if '$DATA(RAUTOE)
WRITE " (Verifier)"
+86 if $DATA(RAUTOE)
SET ^TMP($JOB,"RA AUTOE",RAACNT)=^TMP($JOB,"RA AUTOE",RAACNT)_" (Verifier)"
+87 QUIT
End DoDot:2
+88 IF RAPIR=RAPVERF
IF ('$DATA(RAUTOE))
WRITE " (Pre-Verifier)"
+89 IF RAPIR=RAPVERF
IF ($DATA(RAUTOE))
SET ^TMP($JOB,"RA AUTOE",RAACNT)=^TMP($JOB,"RA AUTOE",RAACNT)_" (Pre-Verifier)"
+90 QUIT
End DoDot:1
if $DATA(RAOOUT)
QUIT
+91 ; Print out secondary interp'ting resident now
DO SECRES^RARTR1
+92 ;P84 kills added
KILL RAPIR,RAPIS
+93 QUIT
+94 ;
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 SET RASSN=$EXTRACT(RASSN,1,3)_"-"_$EXTRACT(RASSN,4,5)_"-"_$EXTRACT(RASSN,6,9)_" "
+19 ; Remedy Call 146291 Changed next line to use RADOB(0)
+20 SET RAGE="DOB-"_$GET(RADOB(0))_" "_$SELECT(RASEX="F":"F",RASEX="M":"M",1:"UNK")
+21 SET $PIECE(RASPACE," ",(22-$LENGTH(RAGE)))=""
+22 SET RAGE=RAGE_RASPACE
SET RACSE="Case: "_RACSE
+23 SET RAREQPHY="Req Phys: "_$EXTRACT(RAREQPHY,1,28)
+24 SET RASPACE=""
SET $PIECE(RASPACE," ",(42-$LENGTH(RAREQPHY)))=""
+25 SET RAREQPHY=RAREQPHY_RASPACE
+26 SET RAPTLOC="Pat Loc: "_$SELECT(RAPTLOC]"":$EXTRACT(RAPTLOC,1,30),1:"Unknown")
+27 SET RATPHY="Att Phys: "_$EXTRACT(RATPHY,1,28)
+28 SET RASPACE=""
SET $PIECE(RASPACE," ",(42-$LENGTH(RATPHY)))=""
+29 SET RATPHY=RATPHY_RASPACE
+30 SET RAILOC="Img Loc: "_$EXTRACT(RAILOC,1,30)
+31 SET RAPRIPHY="Pri Phys: "_$EXTRACT(RAPRIPHY,1,28)
+32 SET RASPACE=""
SET $PIECE(RASPACE," ",(42-$LENGTH(RAPRIPHY)))=""
+33 SET RAPRIPHY=RAPRIPHY_RASPACE
+34 SET RASERV="Service: "_$EXTRACT(RASERV,1,30)
+35 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RANME_RASSN_RAGE_RACSE
+36 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAREQPHY_RAPTLOC
+37 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RATPHY_RAILOC
+38 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAPRIPHY_RASERV
+39 ;p99: get pt sex, add pregnancy screen and pregnancy screen comment
+40 IF $$PTSEX^RAUTL8(RADFN)="F"
IF $DATA(RAY3)
Begin DoDot:1
+41 if RAY3<0
QUIT
+42 NEW RAPCOMM,RA32PSC,DIWF,DIWL,DIWR,X
SET RAPCOMM=$GET(^RADPT(RADFN,"DT",+$GET(RADTI),"P",+$GET(RACNI),"PCOMM"))
+43 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:"")
+44 IF ($PIECE(RAY3,U,32)'="n")
IF $LENGTH(RAPCOMM)
Begin DoDot:2
+45 SET DIWF=""
SET DIWL=3
SET DIWR=75
SET X="Pregnancy Screen Comment: "_RAPCOMM
KILL ^UTILITY($JOB,"W")
DO ^DIWP
+46 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)
+47 KILL ^UTILITY($JOB,"W")
End DoDot:2
End DoDot:1
+48 if $DATA(RAERRFLG)
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2()
+49 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
+50 ;p210/KLM - add to CPRS report if not an outside report or no credit location
+51 NEW RADIVDA,RACRM
SET RADIVDA=$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,3)
SET RACRM=$PIECE($GET(^RA(79.1,$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,4),0)),U,21)
+52 ;p216/KLM - add $G ^ for i-loc lookup (site deleted i-loc)
IF $GET(RAST)'="EF"
IF ($GET(RACRM)'=2)
DO HDRFAC(RADIVDA)
+53 QUIT
HDRFAC(RADIVDA) ;p210/KLM - Add Facility Contact Data for FDA mammography requirement
+1 ;no division passed
if RADIVDA=""
QUIT
+2 NEW RAMADDR,RACSZ,RAFACN,RAPHONE,RAIENDIV,RACNTR,RACOL
SET RACNTR=40
+3 ;new field - facility phone number
SET RAPHONE=$$GET1^DIQ(79,RADIVDA,200)
+4 ;p216 - get physical address, not mailing address
SET RAFACN=$PIECE($$NAME^XUAF4(RADIVDA),U)
SET RAMADDR=$$PADD^XUAF4(RADIVDA)
+5 ;p216 - check mailing if no physical
IF $PIECE(RAMADDR,U,2)=""
SET RAMADDR=$$MADD^XUAF4(RADIVDA)
+6 SET RACSZ=$PIECE(RAMADDR,U,2)_", "_$PIECE(RAMADDR,U,3)_" "_$PIECE($PIECE(RAMADDR,U,4),"-")
+7 IF $DATA(RAUTOE)
Begin DoDot:1
+8 SET RASPACE=""
SET RACNTR=45
+9 SET $PIECE(RASPACE," ",(RACNTR-($LENGTH(RAFACN)/2)))=""
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPACE_RAFACN
+10 SET $PIECE(RASPACE," ",(RACNTR-($LENGTH(RACSZ)/2)))=""
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPACE_RACSZ
+11 SET $PIECE(RASPACE," ",(RACNTR-($LENGTH(RAPHONE)/2)))=""
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPACE_RAPHONE
+12 QUIT
End DoDot:1
QUIT
+13 SET RACOL=RACNTR-($LENGTH(RAFACN)/2)
WRITE !,?RACOL,RAFACN
+14 SET RACOL=RACNTR-($LENGTH(RACSZ)/2)
WRITE !,?RACOL,RACSZ
+15 SET RACOL=RACNTR-($LENGTH(RAPHONE)/2)
WRITE !,?RACOL,RAPHONE
+16 QUIT
