Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAORDU

RAORDU.m

Go to the documentation of this file. 
  1. RAORDU ;HISC/CAH - AISC/RMO-Update Request Status ; 20 Apr 2011  7:30 PM
  1.  ;;5.0;Radiology/Nuclear Medicine;**18,41,57,1003**;Nov 01, 2010;Build 3
  1.  ; last modif JULY 5,00
  1.  ;The variables RAOIFN and RAOSTS must be defined. The variable
  1.  ;RAOREA is set when Canceling and Holding a request. The
  1.  ;variable RAOSCH is set when Scheduling a request.
  1.  ; RAOSTS=request status of exam
  1.  ; RAESTAT=min stat exams same dt/tm^max stat^1(if stat found) 0(else)
  1.  N RAESTAT
  1.  I RAOSTS=2,($$PARNT^RASETU(RAOIFN,RADFN)),($P($G(RAEXM0),"^",25)) D  Q:RAOSTS=6
  1.  . S RAESTAT=$$EN1^RASETU(RAOIFN,RADFN)
  1.  . S RAOSTS=$S((+RAESTAT'<1)&(+RAESTAT'>8):6,1:RAOSTS)
  1.  . K:RAOSTS=6 ORIFN,ORETURN
  1.  . I '$D(RAF1),(+RAESTAT=9) D
  1.  .. W !?3,"...will now designate request status as 'COMPLETE'..."
  1.  .. W !?10,"...request status successfully updated."
  1.  .. Q
  1.  . Q
  1.  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
  1.  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))
  1.  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
  1.  I $D(RAVSTFLG),$D(RAVLEDTI) S DR=DR_";17///^S X="_(9999999.9999-RAVLEDTI)
  1.  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:"")
  1.  S RADIV=$$SITE(),RADIV=$S($D(^RA(79,RADIV,0)):RADIV,1:$O(^RA(79,0)))
  1.  I $D(^RA(79,+RADIV,.1)),$P(^(.1),"^",19)="y" D SETLOG
  1.  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
  1.  ;
  1.  ; if oe/rr v.3 or greater do the following
  1.  ; .send a discontinue or hold message to oe/rr if request status in file
  1.  ;  75.1 is discontinued (1) or hold (3).
  1.  ; .send a complete message to oe/rr if request status in file 75.1 is 
  1.  ;  complete.
  1.  ; .send a scheduled message to oe/rr if request status is active (6) or
  1.  ;  scheduled (8) AND the request was not a rollback from a status of
  1.  ;  complete.
  1.  ;
  1.  I $$ORVR^RAORDU()'<3 D
  1.  . D:(RAOSTS=1)!(RAOSTS=3) EN1^RAO7CH(RAOIFN)
  1.  . D:RAOSTS=2 EN1^RAO7CMP(RAOIFN)
  1.  . 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
  1.  . I ((RAOSTS=6)!(RAOSTS=8))&($P($G(RAORDB4),"^",5)'=2) D
  1.  .. D EN1^RAO7SCH(RAOIFN)
  1.  .. Q
  1.  . Q
  1.  ; ***** PCE changes follow *****
  1.  I $$PCE^RAWORK(),(RAOSTS=2),$G(RASAVDR)'="[RA OVERRIDE]" D
  1.  . N RA7003 S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
  1.  . Q:$P(RA7003,"^",24)="Y"  ; quit if clinic stop credited
  1.  . ;BILLING AWARE PHASE II, NO LONGER SENDING TO PTF
  1.  . ;I $P(RA7003,"^",6)]"",($P(^DIC(42,$P(RA7003,"^",6),0),"^",3)'="D") Q
  1.  . ;omit quit since both inpatient and outpatient data are sent to PCE
  1.  . D COMPLETE^RAPCE(RADFN,RADTI,RACNI)
  1.  . Q
  1.  ; PFSS 1B project. If the request status is discontinue then send the delete event to IBB
  1.  ;IHS/BJI/DAY - Patch 1003 - Comment out call to VA's IBB package
  1.  ;I RAOSTS=1 D DC^RABWIBB(RAOIFN)  ; Requirement 8
  1.  ;End Patch
  1.  Q
  1.  ;
  1. SETLOG 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))
  1.  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:"")
  1.  Q
  1. SETORD ;Create request in OE/RR file and add OE/RR order number to file 75.1
  1.  ; if oe/rr v.3 or greater send an hl7 message when creating a new request/order.
  1.  I $$ORVR^RAORDU()'<3 D EN1^RAO7NEW(RAOIFN) Q
  1.  Q:$$ORVR^RAORDU()'=2.5
  1.  N RAPRGST S RAPRGST=$P(RAORD0,"^",13)
  1.  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),"^"))
  1.  I $$ORVR^RAORDU()=2.5 S (RAPRCD,ORTX(1))=$P($G(^RAMIS(71,+$P(RAORD0,"^",2),0)),"^")_"," D
  1.  .I $D(RAMOD) S ORTX(2)="Modifiers: "_$E(RAMOD,1,80)_","
  1.  .S ORTX(3)="Urgency: "_$S($P(RAORD0,"^",6)=1:"STAT",$P(RAORD0,"^",6)=2:"URGENT",1:"ROUTINE")_","
  1.  .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")_","
  1.  .I $D(RASEX),RASEX'="M" S ORTX(3)=ORTX(3)_" Pregnant: "_$S(RAPRGST="n":"NO",RAPRGST="y":"YES",RAPRGST="u":"UNKNOWN",1:"")
  1.  S ORIT=$P(RAORD0,"^",2)_";RAMIS(71,"
  1.  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)
  1.  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
  1.  I $D(ORIFN),ORIFN]"" S DA=RAOIFN,DIE="^RAO(75.1,",DR="7////^S X="_ORIFN D ^DIE K DE,DQ,DIE,DR
  1.  Q
  1. OERR ;Set ^XUTL("OR",$J,"RA",IFN of oerr,IFN of Rad/Nuc Med order)
  1.  I $D(ORIFN),ORIFN,$D(RAOIFN),RAOIFN S ^XUTL("OR",$J,"RA",ORIFN,RAOIFN)=RADIV
  1.  K RADR1 Q
  1. DELETE W:'$D(ZTQUEUED) !,"Since this order has not been released will delete instead of cancel...",!
  1.  Q
  1.  ;
  1. ORVR() ;returns version number of OE/RR
  1.  ;returns 0 if OE/RR is not installed
  1.  ;
  1.  ;Q 3.0 ;for testing purposes
  1.  Q $S('$D(^ORD(100.99,0)):0,'$D(^DD(100,0,"VR")):0,1:^("VR"))
  1.  ;
  1. ORQUIK() ;returns 1 if CPRS Order Dialogue file 101.41 exists
  1.  ;this means the quick order conversion to file 101.41 has been
  1.  ;done and users should no longer be allowed to edit quick order
  1.  ;parameters in the Common Procedure file 71.3.  The quick order
  1.  ;conversion can be done prior to installing 3.0
  1.  Q $S('$D(^ORD(101.41,0)):0,1:1)
  1.  ;
  1. SITE() ; Determine the value of RADIV
  1.  ; +$P(RA1,"^",22)=Requesting Location
  1.  ; +$P(RA2,"^",15)=Division (pntr to 40.8)
  1.  Q:$D(RADIV)#2 RADIV
  1.  N RA1,RA2,RADIVSON
  1.  S RA1=$G(^RAO(75.1,RAOIFN,0))
  1.  S RA2=$G(^SC(+$P(RA1,"^",22),0))
  1.  S RADIVSON=+$$SITE^VASITE(DT,+$P(RA2,"^",15))
  1.  Q $S(RADIVSON<0:0,1:RADIVSON)