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. ; 06 Oct 2013  11:06 AM
  1.  ;;5.0;Radiology/Nuclear Medicine;**8,26,74,84,99,1003,1005**;Nov 01, 2010;Build 13
  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.  ;
  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.  ... ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist
  1.  ... ;Other verifier may not be a transcriptionist
  1.  ... ;W:RAWHOVER'=RAPIS !?10,"Verified by transcriptionist for "_RALBS  ;Removed RA*5*8 _", M.D."
  1.  ... W:RAWHOVER'=RAPIS !?5,"Verified by ",$$GET1^DIQ(200,+RAWHOVER,.01)," for "_RALBS  ;Removed RA*5*8 _", M.D."
  1.  ... ;End Patch
  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.  ... ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist
  1.  ... ;Other verifier may not be a transcriptionist
  1.  ... ;S:RAWHOVER'=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="          Verified by transcriptionist for "_RALBS  ;Removed RA*5*8 _", M.D."
  1.  ... 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."
  1.  ... ;End Patch
  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.  ... ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist
  1.  ... ;Other verifier may not be a transcriptionist
  1.  ... ;W:RAWHOVER'=RAPIR !?10,"Verified by transcriptionist for "_RALBR  ;Removed RA*5*8 _", M.D."
  1.  ... W:RAWHOVER'=RAPIR !?5,"Verified by ",$$GET1^DIQ(200,+RAWHOVER,.01)," for "_RALBR  ;Removed RA*5*8 _", M.D."
  1.  ... ;End Patch
  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.  ... ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist
  1.  ... ;Other verifier may not be a transcriptionist
  1.  ... ;S:RAWHOVER'=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="          Verified by transcriptionist for "_RALBR  ;Removed RA*5*8 _", M.D."
  1.  ... 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."
  1.  ... ;End Patch
  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.  ;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler 2003 patch
  1.  ;Use standard call for SSN, and remove SSN formatting
  1.  ;S RASSN=$E(RASSN,1,3)_"-"_$E(RASSN,4,5)_"-"_$E(RASSN,6,9)_"    "
  1.  S RASSN=$$SSN^RAUTL,RASSN=RASSN_"    "
  1.  ;End Patch
  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.  ;
  1.  ;IHS/BJI/DAY - Patch 1005 - Gender Fix
  1.  ;I $$PTSEX^RAUTL8(RADFN)="F",$D(RAY3) D
  1.  I $$PTSEX^RAUTL8(RADFN)'="M",$D(RAY3) D
  1.  .;
  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.  Q