source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORDU.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1RAORDU ;HISC/CAH - AISC/RMO-Update Request Status ;9/7/04 11:01am
2 ;;5.0;Radiology/Nuclear Medicine;**18,41,57**;Mar 16, 1998
3 ; last modif JULY 5,00
4 ;The variables RAOIFN and RAOSTS must be defined. The variable
5 ;RAOREA is set when Canceling and Holding a request. The
6 ;variable RAOSCH is set when Scheduling a request.
7 ; RAOSTS=request status of exam
8 ; RAESTAT=min stat exams same dt/tm^max stat^1(if stat found) 0(else)
9 N RAESTAT
10 I RAOSTS=2,($$PARNT^RASETU(RAOIFN,RADFN)),($P($G(RAEXM0),"^",25)) D Q:RAOSTS=6
11 . S RAESTAT=$$EN1^RASETU(RAOIFN,RADFN)
12 . S RAOSTS=$S((+RAESTAT'<1)&(+RAESTAT'>8):6,1:RAOSTS)
13 . K:RAOSTS=6 ORIFN,ORETURN
14 . I '$D(RAF1),(+RAESTAT=9) D
15 .. W !?3,"...will now designate request status as 'COMPLETE'..."
16 .. W !?10,"...request status successfully updated."
17 .. Q
18 . Q
19 I $D(ORSTS),ORSTS=11,$P(^RAO(75.1,RAOIFN,0),"^",5)=11 S ORIFN=+$P(^(0),"^",7),ORSTS="K",DA=RAOIFN,DIK="^RAO(75.1," D DELETE,^DIK K DIK D:ORIFN ST^ORX K ORSTS Q
20 K N I $D(RAOREA)>1 S N=$S($D(RAOIFN):RAOIFN,$D(ORPK):ORPK,1:1) I '$D(RAOREA(N)) S N=$O(RAOREA(0))
21 S DA=RAOIFN,DIE="^RAO(75.1,",DR="10///"_$S($D(RAOREA)&(RAOSTS=1!(RAOSTS=3)):"/^S X="_$S($D(N):RAOREA(N),1:RAOREA),'$D(^RAO(75.1,RAOIFN,0)):"",$P(^(0),"^",10):"@",1:"")_";I 1;5///^S X="_RAOSTS
22 I $D(RAVSTFLG),$D(RAVLEDTI) S DR=DR_";17///^S X="_(9999999.9999-RAVLEDTI)
23 S DR=DR_";18///^S X=""NOW"";23///"_$S($D(RAOSCH)&(RAOSTS=8):"^S X="_RAOSCH,'$D(^RAO(75.1,RAOIFN,0)):"",$P(^(0),"^",23):"@",1:"")
24 S RADIV=$$SITE(),RADIV=$S($D(^RA(79,RADIV,0)):RADIV,1:$O(^RA(79,0)))
25 I $D(^RA(79,+RADIV,.1)),$P(^(.1),"^",19)="y" D SETLOG
26 D ^DIE K DE,DQ,DIE,DR I $$ORVR^RAORDU()=2.5 S ORIFN=$S($D(^RAO(75.1,RAOIFN,0)):+$P(^(0),"^",7),1:0),ORETURN("ORSTS")=RAOSTS D:ORIFN RETURN^ORX K ORIFN,ORETURN
27 ;
28 ; if oe/rr v.3 or greater do the following
29 ; .send a discontinue or hold message to oe/rr if request status in file
30 ; 75.1 is discontinued (1) or hold (3).
31 ; .send a complete message to oe/rr if request status in file 75.1 is
32 ; complete.
33 ; .send a scheduled message to oe/rr if request status is active (6) or
34 ; scheduled (8) AND the request was not a rollback from a status of
35 ; complete.
36 ;
37 I $$ORVR^RAORDU()'<3 D
38 . D:(RAOSTS=1)!(RAOSTS=3) EN1^RAO7CH(RAOIFN)
39 . D:RAOSTS=2 EN1^RAO7CMP(RAOIFN)
40 . I (RAOSTS=6) Q:$G(RA18PCHG,0)=1 ;P18 quit if procedure was changed - do not send "SC" message,because "XX" have been sent already
41 . I ((RAOSTS=6)!(RAOSTS=8))&($P($G(RAORDB4),"^",5)'=2) D
42 .. D EN1^RAO7SCH(RAOIFN)
43 .. Q
44 . Q
45 ; ***** PCE changes follow *****
46 I $$PCE^RAWORK(),(RAOSTS=2),$G(RASAVDR)'="[RA OVERRIDE]" D
47 . N RA7003 S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
48 . Q:$P(RA7003,"^",24)="Y" ; quit if clinic stop credited
49 . ;BILLING AWARE PHASE II, NO LONGER SENDING TO PTF
50 . ;I $P(RA7003,"^",6)]"",($P(^DIC(42,$P(RA7003,"^",6),0),"^",3)'="D") Q
51 . ;omit quit since both inpatient and outpatient data are sent to PCE
52 . D COMPLETE^RAPCE(RADFN,RADTI,RACNI)
53 . Q
54 ; PFSS 1B project. If the request status is discontinue then send the delete event to IBB
55 I RAOSTS=1 D DC^RABWIBB(RAOIFN) ; Requirement 8
56 Q
57 ;
58SETLOG K N I $D(RAOREA)>1 S N=$S($D(RAOIFN):RAOIFN,$D(ORPK):ORPK,1:1) I '$D(RAOREA(N)) S N=$O(RAOREA(0))
59 S DR=DR_";75///^S X=$$MIDNGHT^RAUTL5($$NOW^XLFDT())",DR(2,75.12)="2////^S X="_RAOSTS_";3////^S X="_$S($G(RADUZ):RADUZ,1:DUZ)_";4///"_$S($D(RAOREA)&(RAOSTS=1!(RAOSTS=3)):"/^S X="_$S($D(N):RAOREA(N),1:RAOREA),1:"")
60 Q
61SETORD ;Create request in OE/RR file and add OE/RR order number to file 75.1
62 ; if oe/rr v.3 or greater send an hl7 message when creating a new request/order.
63 I $$ORVR^RAORDU()'<3 D EN1^RAO7NEW(RAOIFN) Q
64 Q:$$ORVR^RAORDU()'=2.5
65 N RAPRGST S RAPRGST=$P(RAORD0,"^",13)
66 K RAMOD S $P(RABLNK," ",41)="" F I=0:0 S I=$O(^RAO(75.1,RAOIFN,"M","B",I)) Q:'I I $D(^RAMIS(71.2,+I,0)) S RAMOD=$S('$D(RAMOD):$P(^(0),"^"),1:RAMOD_", "_$P(^(0),"^"))
67 I $$ORVR^RAORDU()=2.5 S (RAPRCD,ORTX(1))=$P($G(^RAMIS(71,+$P(RAORD0,"^",2),0)),"^")_"," D
68 .I $D(RAMOD) S ORTX(2)="Modifiers: "_$E(RAMOD,1,80)_","
69 .S ORTX(3)="Urgency: "_$S($P(RAORD0,"^",6)=1:"STAT",$P(RAORD0,"^",6)=2:"URGENT",1:"ROUTINE")_","
70 .I $P(RAORD0,"^",19)]"" S X=$P(RAORD0,"^",19),ORTX(3)=ORTX(3)_" Transport: "_$S(X="a":"AMBULATORY",X="p":"PORTABLE",X="s":"STRETCHER",1:"WHEELCHAIR")_","
71 .I $D(RASEX),RASEX'="M" S ORTX(3)=ORTX(3)_" Pregnant: "_$S(RAPRGST="n":"NO",RAPRGST="y":"YES",RAPRGST="u":"UNKNOWN",1:"")
72 S ORIT=$P(RAORD0,"^",2)_";RAMIS(71,"
73 S DIC="^RA(79.2,",DIC(0)="N",X=+$P(^RAMIS(71,+$P(RAORD0,"^",2),0),"^",12) D ^DIC K DIC,RABLNK,RAMOD,RAPRCD S ORPURG=$S(Y<0:30,$D(^RA(79.2,+Y,.1)):+$P(^(.1),"^",6),1:30)
74 S ORVP=RADFN_";DPT(",ORL=RALIFN_";SC(",ORNP=RAPIFN S ORPCL=$O(^ORD(101,"B","RA OERR EXAM",0))_";ORD(101,",ORPK=RAOIFN,ORSTS=$P(RAORD0,"^",5),ORSTRT=$P(RAORD0,"^",21) D FILE^ORX
75 I $D(ORIFN),ORIFN]"" S DA=RAOIFN,DIE="^RAO(75.1,",DR="7////^S X="_ORIFN D ^DIE K DE,DQ,DIE,DR
76 Q
77OERR ;Set ^XUTL("OR",$J,"RA",IFN of oerr,IFN of Rad/Nuc Med order)
78 I $D(ORIFN),ORIFN,$D(RAOIFN),RAOIFN S ^XUTL("OR",$J,"RA",ORIFN,RAOIFN)=RADIV
79 K RADR1 Q
80DELETE W:'$D(ZTQUEUED) !,"Since this order has not been released will delete instead of cancel...",!
81 Q
82 ;
83ORVR() ;returns version number of OE/RR
84 ;returns 0 if OE/RR is not installed
85 ;
86 ;Q 3.0 ;for testing purposes
87 Q $S('$D(^ORD(100.99,0)):0,'$D(^DD(100,0,"VR")):0,1:^("VR"))
88 ;
89ORQUIK() ;returns 1 if CPRS Order Dialogue file 101.41 exists
90 ;this means the quick order conversion to file 101.41 has been
91 ;done and users should no longer be allowed to edit quick order
92 ;parameters in the Common Procedure file 71.3. The quick order
93 ;conversion can be done prior to installing 3.0
94 Q $S('$D(^ORD(101.41,0)):0,1:1)
95 ;
96SITE() ; Determine the value of RADIV
97 ; +$P(RA1,"^",22)=Requesting Location
98 ; +$P(RA2,"^",15)=Division (pntr to 40.8)
99 Q:$D(RADIV)#2 RADIV
100 N RA1,RA2,RADIVSON
101 S RA1=$G(^RAO(75.1,RAOIFN,0))
102 S RA2=$G(^SC(+$P(RA1,"^",22),0))
103 S RADIVSON=+$$SITE^VASITE(DT,+$P(RA2,"^",15))
104 Q $S(RADIVSON<0:0,1:RADIVSON)
Note: See TracBrowser for help on using the repository browser.