source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR0.m@ 696

Last change on this file since 696 was 628, checked in by George Lilly, 16 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.4 KB
Line 
1RARTR0 ;HISC/GJC-Queue/Print Radiology Rpts utility routine. ;1/8/97 08:07
2 ;;5.0;Radiology/Nuclear Medicine;**8,26,74,84**;Mar 16, 1998;Build 13
3 ; 06/28/2006 BAY/KAM Remedy Call 146291 - Change Patient Age to DOB
4 ;
5 ;Integration Agreements
6 ;----------------------
7 ;DT^DILF(2054); GETS^DIQ(2056); $$FMTE^XLFDT(10103); $$UP^XLFSTR(10104)
8 ;NEW PERSON file read w/FM (10060)
9 ;
10EN1 ; Called from RARTR ;P84 GETS^DIQ added...
11 S RARPT(0)=$G(^RARPT(+$G(RARPT),0)) Q:RARPT(0)']""
12 S RARPT(10)=$P(RARPT(0),"^",10)
13 S RAVERF=+$P(RARPT(0),U,9),RAPVERF=+$P(RARPT(0),U,13)
14 K RAPIR,RAPIS S RAPIR=+$P(RALB,"^",12),RAPIS=+$P(RALB,"^",15)
15 ;format of the RAPIR/RAPIS arrays: P84 logic
16 ;RAPI*=IEN file 200
17 ;RAPI*(200,RAPI*,.01)= NAME (required)
18 ;RAPI*(200,RAPI*,20.2) = SIGNATURE BLOCK PRINTED NAME (if any)
19 ;RAPI*(200,RAPI*,20.3) = SIGNATURE BLOCK TITLE (if any)
20 I RAPIR D GETS^DIQ(200,RAPIR,".01;20.2;20.3","","RAPIR") S RAPIR("IENS")=RAPIR_","
21 I RAPIS D GETS^DIQ(200,RAPIS,".01;20.2;20.3","","RAPIS") S RAPIS("IENS")=RAPIS_","
22 S RAWHOVER=+$P(RARPT(0),"^",17)
23 I RAVERF,((RAPIR=RAVERF)!(RAPIS=RAVERF)) D
24 . S RAVERFND="" ; Set verifier found flag
25 . Q
26 I RAPIS D Q:$D(RAOOUT)
27 . ;get signature block name if defined
28 . S RALBS=$E(RAPIS(200,RAPIS("IENS"),20.2),1,25)
29 . S:RALBS="" RALBS=$E(RAPIS(200,RAPIS("IENS"),.01),1,25) ;default to NAME
30 . ;
31 . ;get signature block title if defined
32 . S RALBST=$G(RAPIS(200,RAPIS("IENS"),20.3)) ; max: 50 chars
33 . S:RALBST="" RALBST=$$TITLE^RARTR0(RAPIS)
34 . ;
35 . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT)
36 . I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL
37 . I '$D(RAUTOE) D
38 .. W !,"Primary Interpreting Staff:",!?2,$S(RALBS]"":RALBS,1:"Unknown")
39 .. W:$L(RALBST) ", "_$E(RALBST,1,((IOM-$X)-16))
40 .. ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING
41 .. Q
42 . E D
43 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Staff:"
44 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RALBS]"":RALBS,1:"Unknown")
45 .. Q:'$L(RALBST) N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT))
46 .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBST,1,((80-RALEN)-16))
47 .. Q
48 . I $D(RAVERFND)&(RAPIS=RAVERF),(RAPIS(200,RAPIS("IENS"),.01)'="RADIOLOGY,OUTSIDE SERVICE") D
49 .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q
50 ... W:RAWHOVER=RAPIS !?10,"(Verifier, no e-sig)"
51 ... W:RAWHOVER'=RAPIS !?10,"Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D."
52 ... Q
53 .. I $G(RARPT(10))']"",($D(RAUTOE)) D Q
54 ... S:RAWHOVER=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)"
55 ... S:RAWHOVER'=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D."
56 ... Q
57 .. W:'$D(RAUTOE) " (Verifier)"
58 .. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)"
59 .. Q
60 . I RAPIS=RAPVERF,'$D(RAUTOE) W " (Pre-Verifier)"
61 . I RAPIS=RAPVERF,$D(RAUTOE) S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)"
62 . Q
63 D SECSTF^RARTR1 Q:$D(RAOOUT) ; Print secondary interp'ting staff now
64 ;now for primary resident definitions...
65 I RAPIR D Q:$D(RAOOUT)
66 . ;get signature block name if defined
67 . S RALBR=$E(RAPIR(200,RAPIR("IENS"),20.2),1,25)
68 . S:RALBR="" RALBR=$E(RAPIR(200,RAPIR("IENS"),.01),1,25) ;default to NAME
69 . ;
70 . ;get signature block title if defined
71 . S RALBRT=$G(RAPIR(200,RAPIR("IENS"),20.3)) ; max: 50 chars
72 . S:RALBRT="" RALBRT=$$TITLE^RARTR0(RAPIR)
73 . ;
74 . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT)
75 . I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL
76 . I '$D(RAUTOE) D
77 .. W !,"Primary Interpreting Resident:",!?2,$S(RALBR]"":RALBR,1:"Unknown")
78 .. W:$L(RALBRT) ", "_$E(RALBRT,1,((IOM-$X)-16))
79 .. Q
80 . I $D(RAUTOE) D
81 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Resident:"
82 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RALBR]"":RALBR,1:"Unknown")
83 .. Q:'$L(RALBRT) N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT))
84 .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBRT,1,((80-RALEN)-16))
85 .. Q
86 . I $D(RAVERFND)&(RAPIR=RAVERF) D
87 .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q
88 ... W:RAWHOVER=RAPIR !?10,"(Verifier, no e-sig)"
89 ... W:RAWHOVER'=RAPIR !?10,"Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D."
90 ... Q
91 .. I $G(RARPT(10))']"",($D(RAUTOE)) D Q
92 ... S:RAWHOVER=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)"
93 ... S:RAWHOVER'=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D."
94 ... Q
95 .. W:'$D(RAUTOE) " (Verifier)"
96 .. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)"
97 .. Q
98 . I RAPIR=RAPVERF,('$D(RAUTOE)) W " (Pre-Verifier)"
99 . I RAPIR=RAPVERF,($D(RAUTOE)) S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)"
100 . Q
101 D SECRES^RARTR1 ; Print out secondary interp'ting resident now
102 K RAPIR,RAPIS ;P84 kills added
103 Q
104 ;
105TITLE(X) ;Return the radiology classification in lieu of the signature block title
106 ; 'X' is the IEN of the Primary Interpreting Resident i.e, ^DD(70.03,12
107 ; -OR-
108 ; 'X' is the IEN of the Primary Interpreting Staff i.e, ^DD(70.03,15
109 Q $S($D(^VA(200,"ARC","R",X)):"Resident Physician",$D(^VA(200,"ARC","S",X)):"Staff Physician",1:"")
110 ;
111HEAD ; Set up header info for e-mail message (called from INIT^RARTR)
112 ; 06/28/2006 BAY/KAM Remedy Call 146291 Change Patient Age to DOB
113 N RAGE,RATPHY,RACSE,RAILOC,RANME,RAPRIPHY,RAPTLOC,RAREQPHY,RASERV,RASEX,RADOB
114 N RASPACE,RASSN,X1,X2 S:'$D(RAACNT) RAACNT=0
115 ;Added next line for Remedy Call 146291
116 D DT^DILF("E",$P(RAY0,"^",3),.RADOB) ;Get Date of Birth/External Fmt
117 ;
118 S RANME=$P(RAY0,"^"),RASSN=$P(RAY0,"^",9)
119 S RASEX=$$UP^XLFSTR($P(RAY0,"^",2))
120 S RACSE=$P($G(^RARPT(RARPT,0)),"^")_"@"_$P($$FMTE^XLFDT($P(RAY2,"^")),"@",2)
121 ; Remedy Call 146291 Removed line calculating age
122 S RAREQPHY=$$XTERNAL^RAUTL5($P(RAY3,"^",14),$P($G(^DD(70.03,14,0)),"^",2))
123 S RAPTLOC=$$PTLOC^RAUTL12() S:RAREQPHY']"" RAREQPHY="Unknown"
124 S RASERV=$$XTERNAL^RAUTL5($P(RAY3,"^",7),$P($G(^DD(70.03,7,0)),"^",2))
125 S RATPHY=$$ATND^RAUTL5(RADFN,DT),RAPRIPHY=$$PRIM^RAUTL5(RADFN,DT)
126 S RAILOC=$$XTERNAL^RAUTL5($P(RAY2,"^",4),$P($G(^DD(70.02,4,0)),"^",2))
127 S:RAILOC']"" RAILOC="Unknown" S:RASERV']"" RASERV="Unknown"
128 S RANME=$E(RANME,1,20)_" "
129 S RASSN=$E(RASSN,1,3)_"-"_$E(RASSN,4,5)_"-"_$E(RASSN,6,9)_" "
130 ; Remedy Call 146291 Changed next line to use RADOB(0)
131 S RAGE="DOB-"_RADOB(0)_" "_$S(RASEX="F":"F",RASEX="M":"M",1:"UNK")
132 S $P(RASPACE," ",(22-$L(RAGE)))=""
133 S RAGE=RAGE_RASPACE,RACSE="Case: "_RACSE
134 S RAREQPHY="Req Phys: "_$E(RAREQPHY,1,28)
135 S RASPACE="",$P(RASPACE," ",(42-$L(RAREQPHY)))=""
136 S RAREQPHY=RAREQPHY_RASPACE
137 S RAPTLOC="Pat Loc: "_$S(RAPTLOC]"":$E(RAPTLOC,1,30),1:"Unknown")
138 S RATPHY="Att Phys: "_$E(RATPHY,1,28)
139 S RASPACE="",$P(RASPACE," ",(42-$L(RATPHY)))=""
140 S RATPHY=RATPHY_RASPACE
141 S RAILOC="Img Loc: "_$E(RAILOC,1,30)
142 S RAPRIPHY="Pri Phys: "_$E(RAPRIPHY,1,28)
143 S RASPACE="",$P(RASPACE," ",(42-$L(RAPRIPHY)))=""
144 S RAPRIPHY=RAPRIPHY_RASPACE
145 S RASERV="Service: "_$E(RASERV,1,30)
146 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RANME_RASSN_RAGE_RACSE
147 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAREQPHY_RAPTLOC
148 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RATPHY_RAILOC
149 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAPRIPHY_RASERV
150 S:$D(RAERRFLG) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2()
151 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
152 Q
Note: See TracBrowser for help on using the repository browser.