- 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 Feb 19, 2025@00:04:06 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