RAO7PURG ;HISC/GJC-Purge order request ;9/5/97 08:58
;;5.0;Radiology/Nuclear Medicine;**18**;Mar 16, 1998
;;last modification by SS May 9,2000 for P18
EN1(RAOIFN) ; 'RAOIFN' is the ien in file 75.1
; Create and send HL7 Purge order request msg to CPRS
N RA0,RATAB,RAVAR,RAVARBLE
S RATAB=1 D EN1^RAO7UTL S RA0=$G(^RAO(75.1,RAOIFN,0)) Q:RA0']""
S RAVAR="RATMP(",RAVARBLE="RATMP"
; msh
S @(RAVAR_RATAB_")")=$$MSH^RAO7UTL("ORM^O01") ;P18 event type
; pid
S RATAB=RATAB+1,@(RAVAR_RATAB_")")=$$PID^RAO7UTL(RA0)
; orc
S RATAB=RATAB+1
S @(RAVAR_RATAB_")")="ORC"_RAHLFS_"Z@"_RAHLFS_$P(RA0,"^",7)_"^OR"_RAHLFS_RAOIFN_"^RA"
SHIP ; ship message to MSG^RAO7UTL which fires of the HL7 message to CPRS
D MSG^RAO7UTL("RA EVSEND OR",.@RAVARBLE)
Q
EN2(RAMSG) ; Process purge message from oe/rr (cprs) to Rad/Nuc Med
; Input: RAMSG - HL7 purge request message
; ************************* Variables *********************************
; RAMSH3=sending facility
; RAORC2=<cprs_order_ien>_"^OR"
; RAORC3=<rad/nuc med_order_ien>_"^RA"
; RAPID3=patient internal identifier (ien)
; RAPID5=patient external identifier (name)
; *********************************************************************
D BRKOUT^RAO7UTL1 ; defines RAORC2, RAORC3, RAPID3, RAPID5, RAMSH3
; & RADIV(.119)
N RAFNTDR,RAOIFN,RAORD0 S (RAERR,RALINEX,RAPURGE)=0
F S RALINEX=$O(RAMSG(RALINEX)) Q:RALINEX'>0 D Q:RAERR
. S RASEG=$G(RAMSG(RALINEX)) Q:$P(RASEG,RAHLFS)="MSH"
. S RAHDR=$P(RASEG,RAHLFS),RADATA=$P(RASEG,RAHLFS,2,999)
. D @$S(RAHDR="PID":"PID",RAHDR="ORC":"ORC",1:"ERR")
. Q
Q:RAERR S RAORD0=$G(^RAO(75.1,+RAORC3,0))
S:$$ONLIN(RAORD0) RAERR=24 Q:RAERR ; last activity date for order
; is before the 'Order Data Cut-Off' for the img type
S:$P(RAORD0,"^",5)>5 RAERR=24 Q:RAERR ; can't purge orders that are
; in the following stauses: active, scheduled or unreleased
S:$P(RAORD0,"^",7)="" RAERR=24 Q:RAERR ; missing CPRS order pointer
S:$$GET1^DIQ(100,+$P(RAORD0,"^",7)_",",.01)="" RAERR=24 Q:RAERR ; ptr
; data to file 100 (CPRS Order) is invalid
S RAPUROK=$$PUROK^RAPURGE1(RAORD0,DT),RAOIFN=+RAORC3
D:RAPUROK ENPUR^RAPURGE1
Q ;returns to RAO7RO with RAPUROK set to send OK msg to CPRS
ORC ; breakdown the 'ORC' segment
S RAERR=$$EN3^RAO7VLD(75.1,+RAORC3)
S:RAERR RAERR=22 Q:RAERR ; bad filler number
S:+RAORC2'>0 RAERR=16 Q:RAERR ; bad placer number
S:+RAORC2'=$P($G(^RAO(75.1,+RAORC3,0)),"^",7) RAERR=16 Q:RAERR ; bad placer number
Q
PID ; breakdown the 'PID' segment
S RAERR=$$EN2^RAO7VLD(2,RAPID3,RAPID5) S:RAERR RAERR=2 ; bad patient id
Q
ERR ; error control - file 'soft' errors with CPRS
N RAVAR S RAVAR("XQY0")=""
D ERR^RAO7UTL("HL7 message missing 'PID' & 'ORC' segments",.RAMSG,.RAVAR)
Q
;
ONLIN(RAORD0) ; Check to see if order activity occurred within the number
; of days specified for an order, based on its i-type cut-off parms
; Input: RAORD0-zero node for our order (75.1)
; Output: 1-if order activity occurred later than cut-off date
; 0-if no order activity later than cut-off date
; The 18th piece of 0 node for file 75.1 is 'Last Activity Date/Time'
N RAONLIN,RAX
; if no img type on order, dflt to gen'l rad img type
S RAX=$G(^RA(79.2,$S($P(RAORD0,"^",3)="":+$O(^RA(79.2,0)),1:$P(RAORD0,"^",3)),.1))
S RAONLIN=-$S($P(RAX,"^",6)>29:$P(RAX,"^",6),1:90)
Q:($P(RAORD0,"^",18)\1)<($$FMADD^XLFDT(DT,RAONLIN)) 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAO7PURG 3438 printed Oct 16, 2024@18:38:24 Page 2
RAO7PURG ;HISC/GJC-Purge order request ;9/5/97 08:58
+1 ;;5.0;Radiology/Nuclear Medicine;**18**;Mar 16, 1998
+2 ;;last modification by SS May 9,2000 for P18
EN1(RAOIFN) ; 'RAOIFN' is the ien in file 75.1
+1 ; Create and send HL7 Purge order request msg to CPRS
+2 NEW RA0,RATAB,RAVAR,RAVARBLE
+3 SET RATAB=1
DO EN1^RAO7UTL
SET RA0=$GET(^RAO(75.1,RAOIFN,0))
if RA0']""
QUIT
+4 SET RAVAR="RATMP("
SET RAVARBLE="RATMP"
+5 ; msh
+6 ;P18 event type
SET @(RAVAR_RATAB_")")=$$MSH^RAO7UTL("ORM^O01")
+7 ; pid
+8 SET RATAB=RATAB+1
SET @(RAVAR_RATAB_")")=$$PID^RAO7UTL(RA0)
+9 ; orc
+10 SET RATAB=RATAB+1
+11 SET @(RAVAR_RATAB_")")="ORC"_RAHLFS_"Z@"_RAHLFS_$PIECE(RA0,"^",7)_"^OR"_RAHLFS_RAOIFN_"^RA"
SHIP ; ship message to MSG^RAO7UTL which fires of the HL7 message to CPRS
+1 DO MSG^RAO7UTL("RA EVSEND OR",.@RAVARBLE)
+2 QUIT
EN2(RAMSG) ; Process purge message from oe/rr (cprs) to Rad/Nuc Med
+1 ; Input: RAMSG - HL7 purge request message
+2 ; ************************* Variables *********************************
+3 ; RAMSH3=sending facility
+4 ; RAORC2=<cprs_order_ien>_"^OR"
+5 ; RAORC3=<rad/nuc med_order_ien>_"^RA"
+6 ; RAPID3=patient internal identifier (ien)
+7 ; RAPID5=patient external identifier (name)
+8 ; *********************************************************************
+9 ; defines RAORC2, RAORC3, RAPID3, RAPID5, RAMSH3
DO BRKOUT^RAO7UTL1
+10 ; & RADIV(.119)
+11 NEW RAFNTDR,RAOIFN,RAORD0
SET (RAERR,RALINEX,RAPURGE)=0
+12 FOR
SET RALINEX=$ORDER(RAMSG(RALINEX))
if RALINEX'>0
QUIT
Begin DoDot:1
+13 SET RASEG=$GET(RAMSG(RALINEX))
if $PIECE(RASEG,RAHLFS)="MSH"
QUIT
+14 SET RAHDR=$PIECE(RASEG,RAHLFS)
SET RADATA=$PIECE(RASEG,RAHLFS,2,999)
+15 DO @$SELECT(RAHDR="PID":"PID",RAHDR="ORC":"ORC",1:"ERR")
+16 QUIT
End DoDot:1
if RAERR
QUIT
+17 if RAERR
QUIT
SET RAORD0=$GET(^RAO(75.1,+RAORC3,0))
+18 ; last activity date for order
if $$ONLIN(RAORD0)
SET RAERR=24
if RAERR
QUIT
+19 ; is before the 'Order Data Cut-Off' for the img type
+20 ; can't purge orders that are
if $PIECE(RAORD0,"^",5)>5
SET RAERR=24
if RAERR
QUIT
+21 ; in the following stauses: active, scheduled or unreleased
+22 ; missing CPRS order pointer
if $PIECE(RAORD0,"^",7)=""
SET RAERR=24
if RAERR
QUIT
+23 ; ptr
if $$GET1^DIQ(100,+$PIECE(RAORD0,"^",7)_",",.01)=""
SET RAERR=24
if RAERR
QUIT
+24 ; data to file 100 (CPRS Order) is invalid
+25 SET RAPUROK=$$PUROK^RAPURGE1(RAORD0,DT)
SET RAOIFN=+RAORC3
+26 if RAPUROK
DO ENPUR^RAPURGE1
+27 ;returns to RAO7RO with RAPUROK set to send OK msg to CPRS
QUIT
ORC ; breakdown the 'ORC' segment
+1 SET RAERR=$$EN3^RAO7VLD(75.1,+RAORC3)
+2 ; bad filler number
if RAERR
SET RAERR=22
if RAERR
QUIT
+3 ; bad placer number
if +RAORC2'>0
SET RAERR=16
if RAERR
QUIT
+4 ; bad placer number
if +RAORC2'=$PIECE($GET(^RAO(75.1,+RAORC3,0)),"^",7)
SET RAERR=16
if RAERR
QUIT
+5 QUIT
PID ; breakdown the 'PID' segment
+1 ; bad patient id
SET RAERR=$$EN2^RAO7VLD(2,RAPID3,RAPID5)
if RAERR
SET RAERR=2
+2 QUIT
ERR ; error control - file 'soft' errors with CPRS
+1 NEW RAVAR
SET RAVAR("XQY0")=""
+2 DO ERR^RAO7UTL("HL7 message missing 'PID' & 'ORC' segments",.RAMSG,.RAVAR)
+3 QUIT
+4 ;
ONLIN(RAORD0) ; Check to see if order activity occurred within the number
+1 ; of days specified for an order, based on its i-type cut-off parms
+2 ; Input: RAORD0-zero node for our order (75.1)
+3 ; Output: 1-if order activity occurred later than cut-off date
+4 ; 0-if no order activity later than cut-off date
+5 ; The 18th piece of 0 node for file 75.1 is 'Last Activity Date/Time'
+6 NEW RAONLIN,RAX
+7 ; if no img type on order, dflt to gen'l rad img type
+8 SET RAX=$GET(^RA(79.2,$SELECT($PIECE(RAORD0,"^",3)="":+$ORDER(^RA(79.2,0)),1:$PIECE(RAORD0,"^",3)),.1))
+9 SET RAONLIN=-$SELECT($PIECE(RAX,"^",6)>29:$PIECE(RAX,"^",6),1:90)
+10 if ($PIECE(RAORD0,"^",18)\1)<($$FMADD^XLFDT(DT,RAONLIN))
QUIT 0
+11 QUIT 1
