source: WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR0.m@ 770

Last change on this file since 770 was 623, checked in by George Lilly, 15 years ago

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