source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7XX.m@ 1780

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

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1RAO7XX ;HISC/SS-Sending XX HL7 message to CPRS ;11/19/01 09:07
2 ;;5.0;Radiology/Nuclear Medicine;**18,26,28,32,82**;Mar 16, 1998;Build 8
3 ;Check if requested and registered procedures differ in:
4 ; proc, requesting physician, proc mod(s)
5 ;if there are changes - send XX message and return 1, otherwise 0
6 ; called from RAREG2
7EN1(RAOIFN1) ;P18 entry point for "Register exams" and "Add to last visit" options
8 K RAREGMOD
9 Q:'$D(^RAO(75.1,RAOIFN1,0)) 0
10 Q:'$D(^RAMIS(71,$P(^RAO(75.1,RAOIFN1,0),"^",2),0)) 0
11 N RAPRTYPE S RAPRTYPE=$P(^RAMIS(71,$P(^RAO(75.1,RAOIFN1,0),"^",2),0),"^",6)
12 Q:RAPRTYPE="P" 0 ;quit processing if parent proc, since RAREG2 treats an order, not each descendent of an order, thus no "XX" and no Alert
13 I $$ISCHNGD(RAOIFN1,1)=0 Q 0 ;no changes or no OR*3*92
14CHCK N RAREGMOD S RAREGMOD="R" ;as a flag for registering mode
15 I $$ORVR^RAORDU()'<3 D EN1^RAO7NEW(RAOIFN1) ;sends HL7 message
16 Q 1 ;proc/reqphys/pmod was changed
17 ;
18 ;Can be used only for EXAMS that DO NOT contain Parent procedures
19 ;ISSCHNGD Checks: Was original procedure changed?
20 ;if proc/prc mod/rqstr changed, return 1 to syncrhonize with CPRS
21 ;Usage: RAIEN751 recNo in 75.1 (like RAOIFN)
22 ;if SNDALERT=1 sends alert to provider requested the order
23 ;----------------
24ISCHNGD(RAIEN751,SNDALERT) ;P18
25 N RACHANGE,RAX751,RAX70,RASTRING
26 N RAD751 S RAD751=$G(^RAO(75.1,RAIEN751,0),-1),RASTRING=""
27 Q:RAD751=-1 0
28 N RAPAT S RAPAT=$P(RAD751,"^",1)
29 N RAD70 S RAD70=$$FNDIN70(RAPAT,RAIEN751,"V")
30 N RAD70SB S RAD70SB=$$FNDIN70(RAPAT,RAIEN751,"T")
31 Q:RAD70=0 0
32 N RAPR751 S RAPR751=$P(RAD751,"^",2) ;ien proc from order
33 N RAPHYSID S RAPHYSID=$P(RAD751,"^",14) ;ien req phys
34 S RAPR70=$P(RAD70,"^",2) ;ien proc from exam
35 S RACHANGE=0
36 I RAPR751'=RAPR70,(RAPRTYPE'="P") S RACHANGE=1,$P(RASTRING,"/",4,5)=RAPR751_"/"_RAPR70 ; nonparent,proc changed
37 I RAPR751=RAPR70,(RAPRTYPE'="P") S $P(RASTRING,"/",4)=RAPR751 ;save unchanged proc name
38 I RAPHYSID'=$P(RAD70,"^",14) S RACHANGE=1,$P(RASTRING,"/",6,7)=RAPHYSID_"/"_$P(RAD70,"^",14) ;req phy changed
39 D STR751^RAUTL10(.RAX751,RAIEN751)
40 D STR70^RAUTL10(.RAX70,RAPAT,$P(RAD70SB,"^"),$P(RAD70SB,"^",2))
41 I RAX751'=RAX70 S RACHANGE=1,$P(RASTRING,"/",8,9)=RAX751_"/"_RAX70 ;proc mods changed
42 Q:'RACHANGE 0
43 S $P(RASTRING,"/",1,3)=RAPAT_"/"_$P(RAD70SB,"^")_"/"_$P(RAD70SB,"^",2) ;dfn,invdt,case ien
44 S:$P(RASTRING,"/",6)="" $P(RASTRING,"/",6)=RAPHYSID ;recipient of msg
45 I $G(SNDALERT,0)=1 D
46 . I $$PATCH^XPDUTL("OR*3.0*112") D SETNOTIF^RAO7PC4(RAIEN751) Q
47 . D SETALERT^RAO7PC4
48B1P18 Q:'$$PATCH^XPDUTL("OR*3.0*92") 0 ;CPRS patch not installed yet-return zero (do not send XX message).Alert has been sent above,because it should be sent anyway
49 Q 1 ;one or more changes from orig order AND OR*3*92
50 ;
51 ;RAPT like RADFN
52 ;RADT like RADTI
53 ;RACSN like RACN
54 ;If RARET="V" returns string value, otherwise - $Q of the node
55 ;if failure returns "0"
56FNDIN70M(RAPT,RADT,RACSN,RARET) ;P18
57 N RALV,RALFL
58 S (RALV,RALFL)=0
59 N RALVAR2,RAVAL2
60 S RALV=$O(^RADPT(RAPT,"DT",RADT,"P","B",RACSN,0))
61 Q:+RALV=0 0
62 Q:RARET="V" $G(^RADPT(RAPT,"DT",RADT,"P",RALV,0),0)
63 Q:RARET="T" RADT_"^"_RALV
64 Q $Q(^RADPT(RAPT,"DT",RADT,"P",RALV))
65 ;
66 ;search for #70 entry using PATIEN and Order No from 75.1
67 ;works correctly ONLY FOR ORDERS that do NOT contain PARENT PROCEDURE
68 ;RETRN="V" returns value
69 ;RETRN="T" returns D1^D2 of #70
70 ;otherwise - $Q
71FNDIN70(RAPATN,RAORDN,RETRN) ;
72 N RA18A,RA18B
73 S RA18A=$O(^RADPT("AO",RAORDN,RAPATN,0))
74 Q:RA18A="" 0
75 S RA18B=$O(^RADPT("AO",RAORDN,RAPATN,RA18A,0))
76 Q:RA18B="" 0
77 Q:RETRN="V" $G(^RADPT(RAPATN,"DT",RA18A,"P",RA18B,0),0)
78 Q:RETRN="T" RA18A_"^"_RA18B
79 Q $Q(^RADPT(RAPATN,"DT",RA18A,"P",RA18B))
80 Q
81 ;
82 ;
83UPDTRA0 ;P18 updates var RAO with data from file #70 and sets RAD70SB variable (D2^D3 of #70), called from RAO7NEW
84 N RAD70
85 S RAD70=0
86 ;if registering mode (should not be parent procedure, so we can locate the exam in #70 by OrderN) - data and D2^D3 in #70 for the Order No
87 S:RAREGMOD="R" RAD70=$$FNDIN70(+RA0,RAOIFN,"V"),RAD70SB=$$FNDIN70(+RA0,RAOIFN,"T")
88 ;editing exam had called SVBEFOR, and thus RAPRIEN()s are defined
89 S:RAREGMOD="E" RAD70=$G(^RADPT(RAPRIEN(1),"DT",RAPRIEN(2),"P",RAPRIEN(3),0)),RAD70SB=RAPRIEN(2)_"^"_RAPRIEN(3) S:+RAD70SB=0 RAD70SB=0 S:+RAD70=0 RAD70=0 ;041801 convert null to 0
90 ; updating info
91 I RAD70=0 S $P(RA0,"^",26)="" G ORCSET ; nature of new order activity
92 S:$P(^RAMIS(71,+$P(RA0,"^",2),0),"^",6)'="P" $P(RA0,"^",2)=$P(RAD70,"^",2) ;OBR(4) reset prc only if not parent typ
93 S $P(RA0,"^",9)=$P(RAD70,"^",9) ;Contract/Sharing Source
94 S $P(RA0,"^",14)=$P(RAD70,"^",14) ; req phys ORC(12)
95ORCSET S $P(RA0,"^",15)=DUZ ;ORC(10)
96 Q
97 ;
98MODIF70(RA18D1,RA18D2) ;P18 uses data of Modifiers from #70 for OBR(18)
99 I $O(^RADPT(+RA0,"DT",RA18D1,"P",RA18D2,"M",0)) D
100 . S (A,RAXIT)=0
101 . F S A=$O(^RADPT(+RA0,"DT",RA18D1,"P",RA18D2,"M",A)) Q:A'>0 D Q:RAXIT
102 .. S B(0)=$G(^RADPT(+RA0,"DT",RA18D1,"P",RA18D2,"M",A,0))
103 .. S B(1)=$P($G(^RAMIS(71.2,+B(0),0)),U)
104 .. I $L(RA("OBR",18))+$L(B(1))>60 S RAXIT=1 Q
105 .. S RA("OBR",18)=$G(RA("OBR",18))_B(1)_RAECH(2)
106 .. Q
107 . S RA("OBR",18)=$P(RA("OBR",18),RAECH(2),1,$L(RA("OBR",18),RAECH(2))-1)
108 . Q
109 Q
110SVBEFOR(RAPATN,RAINVDT,RACIEN) ;P18;send radfn,radti,racni (instead of racn and new sequencing of params
111 D SVBEFOR^RAO7UTL(RAPATN,RAINVDT,RACIEN) Q
112 ;Compare proc ien after editing
113CMPAFTR(SNDALERT) ;P18
114 K RAREGMOD
115 I $D(I) N I
116 I $D(J) N J
117 I $D(Y) N Y
118 Q:'$D(RAPRIEN) 0 ;RAPRIEN must be defined by calling SVBEFOR
119 N RADATA,RACHANGE,RAX,RA0,RA1,RA2,RA3,RASTRING,RAPRTYPE
120 S RASTRING=""
121 S RACHANGE=0 ;=1 if changed any of : proc, proc mod, req phys
122 S RADATA=$G(^RADPT(RAPRIEN(1),"DT",RAPRIEN(2),"P",RAPRIEN(3),0))
123 I RADATA="" G CMPEXIT
124 I $P(RADATA,"^",11)="" G CMPEXIT ;can't process unknown proc type
125 S RAPRTYPE=$P($G(^RAMIS(71,+$P($G(^RAO(75.1,+$P(RADATA,"^",11),0)),"^",2),0)),"^",6)
126 I RAPRTYPE="P" G CMPEXIT ; if parent-type, skip both "XX" and Alert
127 ; compare procedure if it's nonparent
128 I $P(RADATA,"^",11),RAPRTYPE'="P",$P(RADATA,"^",2)'=RAPRIEN S RACHANGE=1,$P(RASTRING,"/",4,5)=RAPRIEN_"/"_$P(RADATA,"^",2) ;nonparent proc--changed
129 I $P(RADATA,"^",11),RAPRTYPE'="P",$P(RADATA,"^",2)=RAPRIEN S $P(RASTRING,"/",4)=RAPRIEN ;save unchanged proc name
130 ; compare req phys
131 I $P(RADATA,"^",14)'=RAPRIEN(4) S RACHANGE=1,$P(RASTRING,"/",6,7)=RAPRIEN(4)_"/"_$P(RADATA,"^",14) ;req phy--changed
132 ; compare proc mods
133 D STR70^RAUTL10(.RAX,RAPRIEN(1),RAPRIEN(2),RAPRIEN(3))
134 I RAPRIEN(5)'=RAX S RACHANGE=1,$P(RASTRING,"/",8,9)=RAPRIEN(5)_"/"_RAX ;proc mods-- changed
135 I 'RACHANGE G CMPEXIT
136 S $P(RASTRING,"/",1,3)=RAPRIEN(1)_"/"_RAPRIEN(2)_"/"_RAPRIEN(3)
137 S:$P(RASTRING,"/",6)="" $P(RASTRING,"/",6)=RAPRIEN(4)
138 ; set up of vars for call to XQALERT or to ORB3
139 I $G(SNDALERT,0)=1 D
140 . I $$PATCH^XPDUTL("OR*3.0*112") D SETNOTIF^RAO7PC4($P(RADATA,"^",11)) Q
141 . D SETALERT^RAO7PC4
142B2P18 G:'$$PATCH^XPDUTL("OR*3.0*92") CMPEXIT
143 ;if CPRS patch not installed-don't send any XX message.Checkpoint for all modes except registration,for registration mode see ISCHNGD.Alert has been sent above,because it should be sent anyway
144 N RAREGMOD S RAREGMOD="E" ;edit mode
145 I $$ORVR^RAORDU()'<3 D EN1^RAO7NEW($P(RADATA,"^",11))
146CMPEXIT ;
147 ;Next lines are for RA*5*82
148 G:$G(RACHANGE) QQQ ;If proc, proc mod, req phys changed quit 1
149 S RAX=0 ;Quit 1 if CPT modifier changed or Tech comments changed
150 F S RAX=$O(^RADPT(RAPRIEN(1),"DT",RAPRIEN(2),"P",RAPRIEN(3),"CMOD",RAX)) Q:'RAX I $G(RAPRIEN("CMOD",RAX))'=+$G(^(RAX,0)) S RACHANGE=1 Q
151 G:$G(RACHANGE) QQQ ;
152 S RAX=0
153 F S RAX=$O(^RADPT(RAPRIEN(1),"DT",RAPRIEN(2),"P",RAPRIEN(3),"L",RAX)) Q:'RAX I $G(RAPRIEN("TCOM",RAX))'=$G(^(RAX,"TCOM")) S RACHANGE=1 Q
154QQQ K RAPRIEN Q RACHANGE
155 ;End of RA*5*82 change
156 Q ;OK
157 ;In input templates the TECH COMMENT prompt should follow
158 ;TECHNOILOGIST prompt but on the other hand it must be saved
159 ;ONLY with other Activity log fields. That is why we call TCPROMPT
160 ;from template after TECHNOLOGIST prompt and put the content of
161 ;RA18TCOM in the file 70 only in the very end of editing
162TCPROMPT() ;called from input templates to immitate prompt
163 N RA18A,RA18B,RA18C,DIR,Y,X,DA,DTOUT,DUOUT,DIRUT,DIROUT
164 S RA18A="DESCRIPTION;HELP-PROMPT;INPUT TRANSFORM"
165 D FIELD^DID(70.07,4,"",RA18A,"RA18B") ;field's parameters
166 S DIR(0)="FO^3:255^"_RA18B("INPUT TRANSFORM")
167 S DIR("?")=RA18B("HELP-PROMPT")
168 S DIR("??")="^D DSCRP^RAO7XX"
169 S DIR("A")=" TECHNOLOGIST COMMENT"
170 S RA18C=$$GETTCOM^RAUTL11(RADFN,RADTI,RACNI)
171 S:RA18C'="" DIR("B")=RA18C
172 D ^DIR
173 Q:Y=""!(Y=RA18C) ""
174 Q Y
175 ;
176DSCRP ;get field description
177 N RA18D S RA18D=0
178 F S RA18D=$O(RA18B("DESCRIPTION",RA18D)) Q:RA18D="" W !,RA18B("DESCRIPTION",RA18D)
179 Q
180ZZ(RAPTID,RAPFIEN,RAPTIEN) ; Additional text for display when processing alert.
181 ;
182 S RAPTID=$G(RAPTID) ; IEN of Patient
183 S RAPFIEN=$G(RAPFIEN) ; IEN of Procedure changed FROM
184 S RAPTIEN=$G(RAPTIEN) ; IEN of Procedure changed TO
185 ;
186 N RAPNAM,RAPSSN,RAPRFR,RAPRTO
187 ;
188 S RAPNAM=$$GET1^DIQ(70,+RAPTID,.01) S:RAPNAM="" RAPNAM="UNKNOWN"
189 S RAPSSN=$$GET1^DIQ(70,+RAPTID,.09) S:RAPSSN="" RAPSSN="UNKNOWN"
190 S RAPRFR=$$GET1^DIQ(71,+RAPFIEN,.01) S:RAPRFR="" RAPRFR="UNKNOWN"
191 S RAPRTO=$$GET1^DIQ(71,+RAPTIEN,.01) S:RAPRTO="" RAPRTO="UNKNOWN"
192 ;
193 D EN^DDIOL("Imaging Exam For "_$E(RAPNAM,1,30)_" ("_RAPSSN_") Changed:",,"!!?4")
194 D EN^DDIOL("From: "_RAPRFR,,"!?8")
195 D EN^DDIOL("To: "_RAPRTO,,"!?8")
196 Q
197 ;
Note: See TracBrowser for help on using the repository browser.