source: WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD2.m@ 1582

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

initial load of WorldVistAEHR

File size: 8.1 KB
RevLine 
[613]1RAORD2 ;HISC/CAH,FPT,GJC,DAD AISC/RMO-Detailed Request Display ;9/3/99 13:48
2 ;;5.0;Radiology/Nuclear Medicine;**5,10,51,45,75**;Mar 16, 1998;Build 4
3 K XQADATA
4 D HOME^%ZIS K DIC S DIC="^DPT(",DIC(0)="AEMQ"
5 W ! D ^DIC G Q:Y<0
6 S RADFN=+Y,RANME=$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"Unknown")
7 S RAOFNS="Display",RAOVSTS="1;2;3;5;6;8" D LOCATN I $G(RAQUIT) D Q Q
8 I RAONE]"" S ^TMP($J,"RA L-TYPE",$P(RAONE,"^"),$P(RAONE,"^",2))=""
9 S ^TMP($J,"RA L-TYPE","Unknown")=""
10 I '$D(^TMP($J,"RA L-TYPE")) D ERROR^RAUTL7A D Q QUIT
11 S X=0 W !!,"Imaging Location(s) included:"
12 F S X=$O(^TMP($J,"RA L-TYPE",X)) Q:X']"" D
13 . W:($X+$L(X)+2)'<IOM !?$L("Imaging Location(s) included:") W ?($X+3),X
14 . Q
15 W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DUOUT)!($D(DTOUT)) D Q Q
16 D ^RAORDS G Q:'$D(RAORDS)
17OERR ; Entry Point for OE/RR Cancel/Hold Alert
18 I $D(XQADATA) D
19 . S RAORDS(1)=+XQADATA
20 . I $P(XQADATA,",",2)'="" S RADFN=$P(XQADATA,",",2)
21 S RAPKG="",RAOSTSYM="dc^c^h^^p^^^s",$P(RALNE,"-",79)="",RAX=""
22 F RAOLP=1:1 S RAOIFN=$S($D(RAORDS(RAOLP)):RAORDS(RAOLP),1:0) Q:'RAOIFN!(RAX=U) D DISORD
23 ;
24 K:RAX="^" XQAID,XQAKILL I $D(XQAID) S DFN=$P(XQAID,",",2) D DELETE^XQALERT
25Q K %,DIC,I,OREND,RA,RACI,RACNI,RADFN,RADIV,RADIVPAR,RADPT0,RADTI,RALNE
26 K RANME,RAOFNS,RAOIFN,RAOLP,RAORD0,RAORDS,RAOSTS,RAOSTSYM,RAOVSTS,RAPKG
27 K RAONE,RAQUIT,RASSN,X,XQAID,XQALERT,Y,RAX,VA200,VAERR,VAIP
28 K RAPARENT,RACMFLG
29 K DFN,DIPGM,DISYS,DIW,DIWI,DIWT,DIWTC,DIWX,DN,RA6,RA7,POP,^TMP($J,"PRO-ORD")
30 K ^TMP($J,"RA L-TYPE"),^TMP($J,"RAORDS"),^TMP($J,"RA DIFF PRC") Q
31 ;
32 ;
33DISORD Q:'$D(^DPT(RADFN,0)) S RADPT0=^(0),RA("NME")=$P(RADPT0,"^"),RA("DOB")=$P(RADPT0,"^",3),RASSN=$$SSN^RAUTL Q:'$D(^RAO(75.1,RAOIFN,0)) S RAORD0=^(0)
34 ;determine if ordered procedure has CM assoc.; return null if none
35 S RAZPRC0=$G(^RAMIS(71,+$P(RAORD0,U,2),0))
36 S RACMFLG("O")=$$CMEDIA^RAO7UTL(+$P(RAORD0,U,2),$P(RAZPRC0,U,6))
37 K RAZPRC0
38 I $D(^RADPT("AO",RAOIFN,RADFN)) D DPRC(RAOIFN,RADFN)
39 S RA("PROC. NODE")=$G(^RAMIS(71,+$P(RAORD0,U,2),0))
40 S RA("PRC")=$E($P(RA("PROC. NODE"),U),1,36)
41 S RA("PRCTY")=$P(RA("PROC. NODE"),U,6)
42 S RA("PRCTY")=$$XTERNAL^RAUTL5(RA("PRCTY"),$P($G(^DD(71,6,0)),U,2))
43 S RA("PRCTY")=$E(RA("PRCTY"))_$$LOW^XLFSTR($E(RA("PRCTY"),2,99))
44 S RA("CPT")=+$P(RA("PROC. NODE"),U,9)
45 ; don't find CPT code if procedure has type = Parent
46 S RA("CPT")=$S($E(RA("PRCTY"))="P":"",1:$P($$NAMCODE^RACPTMSC(RA("CPT"),DT),U))
47 S RA("PRCIT")=+$P(RA("PROC. NODE"),U,12)
48 S RA("PRCIT")=$P($G(^RA(79.2,RA("PRCIT"),0)),U,3)
49 S RA("PROC INFO")="",$E(RA("PROC INFO"),1,36)=RA("PRC")
50 S RA("CNCAT")="("_RA("PRCIT")_" "_RA("PRCTY")_" "_RA("CPT")_")"
51 S $E(RA("PROC INFO"),38,60)=RA("CNCAT") K RA("CNCAT"),RA("PRCIT")
52 K RA("PRCTY"),RA("CPT")
53 S RA("STY_REA")=$P($G(^RAO(75.1,RAOIFN,.1)),U) ;P75
54 K RA("MOD") F I=0:0 S I=$O(^RAO(75.1,RAOIFN,"M","B",I)) Q:'I I $D(^RAMIS(71.2,+I,0)) S RA("MOD")=$S('$D(RA("MOD")):$P(^(0),"^"),1:RA("MOD")_", "_$P(^(0),"^"))
55 S RA("OST")=$P($P(^DD(75.1,5,0),$P(RAORD0,"^",5)_":",2),";")_$S($P(RAOSTSYM,"^",$P(RAORD0,"^",5))="":"",1:" ("_$P(RAOSTSYM,"^",$P(RAORD0,"^",5))_")")
56 S RA("PHY")=$S($D(^VA(200,+$P(RAORD0,"^",14),0)):$P(^(0),"^"),1:"")
57 ; Requesting Physician phone/pager info
58 D PHONE^RAORD5("R",+$P(RAORD0,"^",14))
59 S RA("HLC")=$S($D(^SC(+$P(RAORD0,"^",22),0)):$P(^(0),"^"),1:"")
60 S DFN=RADFN,VA200=1 D IN5^VADPT I VAIP(1) S RA("ROOM-BED")=$S(+VAIP(6):$P(VAIP(6),"^",2),1:"")
61 K RA("ODT") S X=$P(RAORD0,"^",16) I X S:$P(X,".",2) X=$P(X,".")_"."_$$NOSECNDS^RAORD3($P(X,".",2)) S RA("ODT")=$$FMTE^XLFDT(X,"1P")
62 S RA("USR")=$S($D(^VA(200,+$P(RAORD0,"^",15),0)):$P(^(0),"^"),1:"")
63 D HDR ; display a header
64 W !,"Requested :",?12,RA("PROC INFO")
65 I $D(^TMP($J,"RA DIFF PRC")) D
66 .N CRTN,I S CRTN=0,I="" W !,"Registered:"
67 .F S I=$O(^TMP($J,"RA DIFF PRC",I)) Q:I']"" D
68 ..W:CRTN ! W ?12,I S CRTN=1
69 .Q
70 I $G(RACMFLG("O"))'="" W:$X ! W ?12,"** The requested procedure has contrast media assigned **"
71 I $G(RACMFLG("R"))'="" W:$X ! W ?12,"** A registered procedure uses contrast media **"
72 W:$D(RA("MOD")) !,"Procedure Modifiers:",?22,RA("MOD")
73 W !!,"Current Status:",?22,$E(RA("OST"),1,24)
74 W !,"Requester:",?22,$E(RA("PHY"),1,24)
75 W !?1,"Tel/Page/Dig Page: ",RA("RPHOINFO")
76 W !,"Patient Location:",?22,$E(RA("HLC"),1,20)
77 W:$D(RA("ROOM-BED")) !,"Room-Bed:",?22,$E(RA("ROOM-BED"),1,20)
78 W !,"Entered:",?22,$S($D(RA("ODT")):RA("ODT"),1:"")," by ",$E(RA("USR"),1,20)
79 ;
80ENDIS ;OE/RR Entry Point for the PRINT ACTION Option
81 I '$D(RAPKG) Q:'$D(ORPK) S RAOIFN=+ORPK Q:'$D(^RAO(75.1,RAOIFN,0)) S RAORD0=^(0),RADFN=+$P(RAORD0,"^")
82 S RA("TRAN")=$S($P(RAORD0,"^",19)']"":"",1:$P($P(^DD(75.1,19,0),$P(RAORD0,"^",19)_":",2),";"))
83 K RA("ST") I $D(^RADPT("AO",RAOIFN,RADFN)) S RADTI=+$O(^(RADFN,0)),RACNI=+$O(^(RADTI,0)) I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S RA(0)=^(0) I $D(^RA(72,+$P(RA(0),"^",3),0)) S RA("ST")=$P(^(0),"^")
84 I '$D(RAPKG) D DPRC(RAOIFN,RADFN) K ^TMP($J,"RA DIFF PRC")
85 S RADIV(0)=$G(^SC(+$P(RAORD0,"^",22),0))
86 S RADIV=+$$SITE^VASITE(DT,+$P(RADIV(0),"^",15)) S:RADIV<0 RADIV=0
87 S RADIV=$S($D(^RA(79,RADIV,0)):RADIV,1:$O(^RA(79,0)))
88 S RADIVPAR=$S($D(^RA(79,+RADIV,.1)):^(.1),1:"")
89 K RA("RDT") S Y=$P(RAORD0,"^",21) I Y S:$P(Y,".",2) Y=$P(Y,".")_"."_$$NOSECNDS^RAORD3($P(Y,".",2)) S RA("RDT")=$$FMTE^XLFDT(Y,"1P")
90 K RA("PDT") S Y=$P(RAORD0,"^",12) I Y S:$P(Y,".",2) Y=$P(Y,".")_"."_$$NOSECNDS^RAORD3($P(Y,".",2)) S RA("PDT")=$$FMTE^XLFDT(Y,"1P")
91 K RA("VDT") S Y=$P(RAORD0,"^",17) I Y S:$P(Y,".",2) Y=$P(Y,".")_"."_$$NOSECNDS^RAORD3($P(Y,".",2)) S RA("VDT")=$$FMTE^XLFDT(Y,"1P")
92 K RA("SDT") S Y=$P(RAORD0,"^",23) I Y S:$P(Y,".",2) Y=$P(Y,".")_"."_$$NOSECNDS^RAORD3($P(Y,".",2)) S RA("SDT")=$$FMTE^XLFDT(Y,"1P")
93 S RA("ILC")=$S('$P(RAORD0,"^",20):"UNKNOWN",'$D(^RA(79.1,+$P(RAORD0,"^",20),0)):"UNKNOWN",$D(^SC(+^(0),0)):$P(^(0),"^"),1:"UNKNOWN")
94 I $S('$D(XQORNOD(0)):0,$P(XQORNOD(0),"^",3)'="Results Display":0,1:1),$D(RA(0)) D ^RAORR3 Q
95 D ^RAORD3 K RA,RACI,RACNI,RADIV,RADIVPAR,RADPT0,RADTI,RAORD0,RAOSTS,X,Y I '$D(RAPKG) K RADFN,RAOIFN
96 Q
97LOCATN ; Select or default to a Rad/Nuc Med location.
98 S RAONE=$$LOC1() Q:RAONE]""
99 S RADIC="^RA(79.1,",RADIC(0)="QEAMZ"
100 S RADIC("A")="Select Rad/Nuc Med Location: "
101 S RADIC("B")="All",RAUTIL="RA L-TYPE"
102 W !! D EN1^RASELCT(.RADIC,RAUTIL) K DIC,RADIC,RAUTIL,X,Y
103 Q
104LOC1() ; Checking for only one Imaging Location
105 ; Pass back null if more that one entry exists in 79.1
106 ; If one entry, pass back: external Hosp. Loc. file_"^"_IEN of file 79.1
107 N X,Y S X=""
108 I $P($G(^RA(79.1,0)),"^",4)=1 D
109 . S Y=+$O(^RA(79.1,0)) Q:'Y
110 . S Y(0)=$G(^RA(79.1,Y,0)),Y(1)=+$P(Y(0),"^")
111 . S Y(44)=$P($G(^SC(Y(1),0)),"^"),X=Y(44)_"^"_Y
112 . Q
113 Q X
114HDR ; Header for the 'Detailed Request Display' option. Called from above
115 ; (D HDR) and from RAORD3
116 W @IOF,?22,"**** Detailed Display ****",!!,"Name: ",RA("NME")," (",RASSN,")" S Y=RA("DOB") D D^RAUTL W ?45,"Date of Birth: ",Y,!,RALNE
117 Q
118 ;
119DPRC(RAOIFN,RADFN) ; If the ordered procedure has been registered check
120 ;if this is an examset. If not an examset, find the status of the exam
121 ;RA("ST"). Also, check if the ordered procedure has been changed at
122 ;time of registration (DPROC^RAUTL15). If it has, store the data off
123 ;in ^TMP($J,"RA DIFF PRC").
124 ;
125 ; NOTE: The only time we don't set ^TMP($J,"RA DIFF PRC") is when
126 ; we are using the 'Detailed Request Display' option and the ordered
127 ; procedure is the same as the registered procedure. All other
128 ; Request display options output the ordered procedure, the
129 ; registered procedure and exam case number if the order
130 ; is active.
131 ;
132 ;Set the variable RACMFLG("R") to "Y" if an exam, either a single or
133 ;descendant, has used contrast media during the examination.
134 ;
135 N RA7003,RACNI,RADTI,RAFLG K RA("ST"),^TMP($J,"RA DIFF PRC")
136 S (RADTI,RAFLG)=0
137 F S RADTI=+$O(^RADPT("AO",RAOIFN,RADFN,RADTI)) Q:RADTI'>0 D
138 . S RACNI=0
139 . F S RACNI=$O(^RADPT("AO",RAOIFN,RADFN,RADTI,RACNI)) Q:RACNI'>0 D
140 .. I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) D
141 ... S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),RAFLG=RAFLG+1
142 ... S:$G(RACMFLG("R"))="" RACMFLG("R")=$S($P(RA7003,U,10)="Y":"Y",1:"")
143 ... S RA("ST")=$$GET1^DIQ(72,+$P(RA7003,"^",3)_",",.01)
144 ... N RAPRC S RAPRC=$$DPROC^RAUTL15(RADFN,RADTI,RACNI,RAOIFN)
145 ... S:RAPRC]"" ^TMP($J,"RA DIFF PRC",RAPRC)=""
146 ... Q
147 .. Q
148 . Q
149 K:RAFLG>1 RA("ST") ; >1 reg. xam for this order, RA("ST") not valid
150 Q
Note: See TracBrowser for help on using the repository browser.