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

RARTR0.m

Go to the documentation of this file.
  1. 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
  1. ; 06/28/2006 BAY/KAM Remedy Call 146291 - Change Patient Age to DOB
  1. ;
  1. ;Integration Agreements
  1. ;----------------------
  1. ;DT^DILF(2054); GETS^DIQ(2056); $$FMTE^XLFDT(10103); $$UP^XLFSTR(10104); ^DIWP(10011)
  1. ;NEW PERSON file read w/FM (10060)
  1. ;$$NAME^XUAF4,$$MADD^XUAF4(2171)
  1. ;
  1. EN1 ; Called from RARTR ;P84 GETS^DIQ added...
  1. S RARPT(0)=$G(^RARPT(+$G(RARPT),0)) Q:RARPT(0)']""
  1. S RARPT(10)=$P(RARPT(0),"^",10)
  1. S RAVERF=+$P(RARPT(0),U,9),RAPVERF=+$P(RARPT(0),U,13)
  1. K RAPIR,RAPIS S RAPIR=+$P(RALB,"^",12),RAPIS=+$P(RALB,"^",15)
  1. ;format of the RAPIR/RAPIS arrays: P84 logic
  1. ;RAPI*=IEN file 200
  1. ;RAPI*(200,RAPI*,.01)= NAME (required)
  1. ;RAPI*(200,RAPI*,20.2) = SIGNATURE BLOCK PRINTED NAME (if any)
  1. ;RAPI*(200,RAPI*,20.3) = SIGNATURE BLOCK TITLE (if any)
  1. I RAPIR D GETS^DIQ(200,RAPIR,".01;20.2;20.3","","RAPIR") S RAPIR("IENS")=RAPIR_","
  1. I RAPIS D GETS^DIQ(200,RAPIS,".01;20.2;20.3","","RAPIS") S RAPIS("IENS")=RAPIS_","
  1. S RAWHOVER=+$P(RARPT(0),"^",17)
  1. I RAVERF,((RAPIR=RAVERF)!(RAPIS=RAVERF)) D
  1. . S RAVERFND="" ; Set verifier found flag
  1. . Q
  1. I RAPIS D Q:$D(RAOOUT)
  1. . ;get signature block name if defined
  1. . S RALBS=$E(RAPIS(200,RAPIS("IENS"),20.2),1,25)
  1. . S:RALBS="" RALBS=$E(RAPIS(200,RAPIS("IENS"),.01),1,25) ;default to NAME
  1. . ;
  1. . ;get signature block title if defined
  1. . S RALBST=$G(RAPIS(200,RAPIS("IENS"),20.3)) ; max: 50 chars
  1. . S:RALBST="" RALBST=$$TITLE^RARTR0(RAPIS)
  1. . ;
  1. . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT)
  1. . I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL
  1. . I '$D(RAUTOE) D
  1. .. W !,"Primary Interpreting Staff:",!?2,$S(RALBS]"":RALBS,1:"Unknown")
  1. .. W:$L(RALBST) ", "_$E(RALBST,1,((IOM-$X)-16))
  1. .. ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING
  1. .. Q
  1. . E D
  1. .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Staff:"
  1. .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RALBS]"":RALBS,1:"Unknown")
  1. .. Q:'$L(RALBST) N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT))
  1. .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBST,1,((80-RALEN)-16))
  1. .. Q
  1. . I $D(RAVERFND)&(RAPIS=RAVERF),(RAPIS(200,RAPIS("IENS"),.01)'="RADIOLOGY,OUTSIDE SERVICE") D
  1. .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q
  1. ... W:RAWHOVER=RAPIS !?10,"(Verifier, no e-sig)"
  1. ... W:RAWHOVER'=RAPIS !?10,"Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D."
  1. ... Q
  1. .. I $G(RARPT(10))']"",($D(RAUTOE)) D Q
  1. ... S:RAWHOVER=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)"
  1. ... S:RAWHOVER'=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D."
  1. ... Q
  1. .. W:'$D(RAUTOE) " (Verifier)"
  1. .. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)"
  1. .. Q
  1. . I RAPIS=RAPVERF,'$D(RAUTOE) W " (Pre-Verifier)"
  1. . I RAPIS=RAPVERF,$D(RAUTOE) S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)"
  1. . Q
  1. D SECSTF^RARTR1 Q:$D(RAOOUT) ; Print secondary interp'ting staff now
  1. ;now for primary resident definitions...
  1. I RAPIR D Q:$D(RAOOUT)
  1. . ;get signature block name if defined
  1. . S RALBR=$E(RAPIR(200,RAPIR("IENS"),20.2),1,25)
  1. . S:RALBR="" RALBR=$E(RAPIR(200,RAPIR("IENS"),.01),1,25) ;default to NAME
  1. . ;
  1. . ;get signature block title if defined
  1. . S RALBRT=$G(RAPIR(200,RAPIR("IENS"),20.3)) ; max: 50 chars
  1. . S:RALBRT="" RALBRT=$$TITLE^RARTR0(RAPIR)
  1. . ;
  1. . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT)
  1. . I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL
  1. . I '$D(RAUTOE) D
  1. .. W !,"Primary Interpreting Resident:",!?2,$S(RALBR]"":RALBR,1:"Unknown")
  1. .. W:$L(RALBRT) ", "_$E(RALBRT,1,((IOM-$X)-16))
  1. .. Q
  1. . I $D(RAUTOE) D
  1. .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Resident:"
  1. .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RALBR]"":RALBR,1:"Unknown")
  1. .. Q:'$L(RALBRT) N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT))
  1. .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBRT,1,((80-RALEN)-16))
  1. .. Q
  1. . I $D(RAVERFND)&(RAPIR=RAVERF) D
  1. .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q
  1. ... W:RAWHOVER=RAPIR !?10,"(Verifier, no e-sig)"
  1. ... W:RAWHOVER'=RAPIR !?10,"Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D."
  1. ... Q
  1. .. I $G(RARPT(10))']"",($D(RAUTOE)) D Q
  1. ... S:RAWHOVER=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)"
  1. ... S:RAWHOVER'=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D."
  1. ... Q
  1. .. W:'$D(RAUTOE) " (Verifier)"
  1. .. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)"
  1. .. Q
  1. . I RAPIR=RAPVERF,('$D(RAUTOE)) W " (Pre-Verifier)"
  1. . I RAPIR=RAPVERF,($D(RAUTOE)) S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)"
  1. . Q
  1. D SECRES^RARTR1 ; Print out secondary interp'ting resident now
  1. K RAPIR,RAPIS ;P84 kills added
  1. Q
  1. ;
  1. 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
  1. ; -OR-
  1. ; 'X' is the IEN of the Primary Interpreting Staff i.e, ^DD(70.03,15
  1. Q $S($D(^VA(200,"ARC","R",X)):"Resident Physician",$D(^VA(200,"ARC","S",X)):"Staff Physician",1:"")
  1. ;
  1. ; 06/28/2006 BAY/KAM Remedy Call 146291 Change Patient Age to DOB
  1. N RAGE,RATPHY,RACSE,RAILOC,RANME,RAPRIPHY,RAPTLOC,RAREQPHY,RASERV,RASEX,RADOB
  1. N RASPACE,RASSN,X1,X2 S:'$D(RAACNT) RAACNT=0
  1. ;Added next line for Remedy Call 146291
  1. D DT^DILF("E",$P(RAY0,"^",3),.RADOB) ;Get Date of Birth/External Fmt
  1. ;
  1. S RANME=$P(RAY0,"^"),RASSN=$P(RAY0,"^",9)
  1. S RASEX=$$UP^XLFSTR($P(RAY0,"^",2))
  1. S RACSE=$P($G(^RARPT(RARPT,0)),"^")_"@"_$P($$FMTE^XLFDT($P(RAY2,"^")),"@",2)
  1. ; Remedy Call 146291 Removed line calculating age
  1. S RAREQPHY=$$XTERNAL^RAUTL5($P(RAY3,"^",14),$P($G(^DD(70.03,14,0)),"^",2))
  1. S RAPTLOC=$$PTLOC^RAUTL12() S:RAREQPHY']"" RAREQPHY="Unknown"
  1. S RASERV=$$XTERNAL^RAUTL5($P(RAY3,"^",7),$P($G(^DD(70.03,7,0)),"^",2))
  1. S RATPHY=$$ATND^RAUTL5(RADFN,DT),RAPRIPHY=$$PRIM^RAUTL5(RADFN,DT)
  1. S RAILOC=$$XTERNAL^RAUTL5($P(RAY2,"^",4),$P($G(^DD(70.02,4,0)),"^",2))
  1. S:RAILOC']"" RAILOC="Unknown" S:RASERV']"" RASERV="Unknown"
  1. S RANME=$E(RANME,1,20)_" "
  1. S RASSN=$E(RASSN,1,3)_"-"_$E(RASSN,4,5)_"-"_$E(RASSN,6,9)_" "
  1. ; Remedy Call 146291 Changed next line to use RADOB(0)
  1. S RAGE="DOB-"_$G(RADOB(0))_" "_$S(RASEX="F":"F",RASEX="M":"M",1:"UNK")
  1. S $P(RASPACE," ",(22-$L(RAGE)))=""
  1. S RAGE=RAGE_RASPACE,RACSE="Case: "_RACSE
  1. S RAREQPHY="Req Phys: "_$E(RAREQPHY,1,28)
  1. S RASPACE="",$P(RASPACE," ",(42-$L(RAREQPHY)))=""
  1. S RAREQPHY=RAREQPHY_RASPACE
  1. S RAPTLOC="Pat Loc: "_$S(RAPTLOC]"":$E(RAPTLOC,1,30),1:"Unknown")
  1. S RATPHY="Att Phys: "_$E(RATPHY,1,28)
  1. S RASPACE="",$P(RASPACE," ",(42-$L(RATPHY)))=""
  1. S RATPHY=RATPHY_RASPACE
  1. S RAILOC="Img Loc: "_$E(RAILOC,1,30)
  1. S RAPRIPHY="Pri Phys: "_$E(RAPRIPHY,1,28)
  1. S RASPACE="",$P(RASPACE," ",(42-$L(RAPRIPHY)))=""
  1. S RAPRIPHY=RAPRIPHY_RASPACE
  1. S RASERV="Service: "_$E(RASERV,1,30)
  1. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RANME_RASSN_RAGE_RACSE
  1. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAREQPHY_RAPTLOC
  1. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RATPHY_RAILOC
  1. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAPRIPHY_RASERV
  1. ;p99: get pt sex, add pregnancy screen and pregnancy screen comment
  1. I $$PTSEX^RAUTL8(RADFN)="F",$D(RAY3) D
  1. .Q:RAY3<0
  1. .N RAPCOMM,RA32PSC,DIWF,DIWL,DIWR,X S RAPCOMM=$G(^RADPT(RADFN,"DT",+$G(RADTI),"P",+$G(RACNI),"PCOMM"))
  1. .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:"")
  1. .I ($P(RAY3,U,32)'="n"),$L(RAPCOMM) D
  1. ..S DIWF="",DIWL=3,DIWR=75,X="Pregnancy Screen Comment: "_RAPCOMM K ^UTILITY($J,"W") D ^DIWP
  1. ..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)
  1. ..K ^UTILITY($J,"W")
  1. S:$D(RAERRFLG) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2()
  1. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
  1. ;p210/KLM - add to CPRS report if not an outside report or no credit location
  1. 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)
  1. I $G(RAST)'="EF",($G(RACRM)'=2) D HDRFAC(RADIVDA) ;p216/KLM - add $G ^ for i-loc lookup (site deleted i-loc)
  1. Q
  1. HDRFAC(RADIVDA) ;p210/KLM - Add Facility Contact Data for FDA mammography requirement
  1. Q:RADIVDA="" ;no division passed
  1. N RAMADDR,RACSZ,RAFACN,RAPHONE,RAIENDIV,RACNTR,RACOL S RACNTR=40
  1. S RAPHONE=$$GET1^DIQ(79,RADIVDA,200) ;new field - facility phone number
  1. S RAFACN=$P($$NAME^XUAF4(RADIVDA),U),RAMADDR=$$PADD^XUAF4(RADIVDA) ;p216 - get physical address, not mailing address
  1. I $P(RAMADDR,U,2)="" S RAMADDR=$$MADD^XUAF4(RADIVDA) ;p216 - check mailing if no physical
  1. S RACSZ=$P(RAMADDR,U,2)_", "_$P(RAMADDR,U,3)_" "_$P($P(RAMADDR,U,4),"-")
  1. I $D(RAUTOE) D Q
  1. .S RASPACE="",RACNTR=45
  1. .S $P(RASPACE," ",(RACNTR-($L(RAFACN)/2)))="" S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPACE_RAFACN
  1. .S $P(RASPACE," ",(RACNTR-($L(RACSZ)/2)))="" S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPACE_RACSZ
  1. .S $P(RASPACE," ",(RACNTR-($L(RAPHONE)/2)))="" S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPACE_RAPHONE
  1. .Q
  1. S RACOL=RACNTR-($L(RAFACN)/2) W !,?RACOL,RAFACN
  1. S RACOL=RACNTR-($L(RACSZ)/2) W !,?RACOL,RACSZ
  1. S RACOL=RACNTR-($L(RAPHONE)/2) W !,?RACOL,RAPHONE
  1. Q