- 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 Jan 18, 2025@03:40:26 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