- RAPURGE1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Purge Rad/NM Data ;9/3/97 12:22
- ;;5.0;Radiology/Nuclear Medicine;**34**;Mar 16, 1998
- START I $G(RAPURTYP)="" U IO W !,"RAPURTYP undefined or null, Purge Not Done." G EXIT
- U IO D NOW^%DTC S Y=%,RACRT=$E(IOST,1,2)="C-" K %,%H,%I W !!,"Purge data routine started at " D D^RAUTL W Y,"."
- ;Set up variables needed for purge of selected imaging types
- G EXIT:'$O(RAPUR(0))
- S (RADT,RAODT,RAIEN)=0 F S RAIEN=$O(RAPUR(RAIEN)) Q:'RAIEN S RAX=$G(^RA(79.2,RAIEN,.1)) D
- .F RAI=1:1:4 S X2=-$S($P(RAX,U,RAI)>89:$P(RAX,U,RAI),1:27393),X1=DT D C^%DTC S $P(RAPUR(RAIEN),"^",RAI)=X S:X>RADT RADT=X
- .S X2=-$S($P(RAX,U,6)>29:$P(RAX,U,6),1:27393),X1=DT D C^%DTC S $P(RAPUR(RAIEN),"^",5)=X S:X>RAODT RAODT=X
- .F RAI=6:1:8 S $P(RAPUR(RAIEN),"^",RAI)=0
- ;
- EXAM ;Purge exam/report data
- I RAPURTYP="O" G ORDER
- W !!,"Purging exams/reports.",!
- F RADTE=0:0 S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>RADT) S RADTI=9999999.9999-RADTE F RADFN=0:0 S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0 D
- .F RACN=0:0 S RACN=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN)) Q:RACN'>0 S RACNI=+$O(^(RACN,0)),RA0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),RARPT=+$P(RA0,"^",17) D:$S('$D(^("NOPURGE")):1,^("NOPURGE")'="n":1,1:0)
- ..S RAIMAG=+$P($G(^RAMIS(71,+$P(RA0,"^",2),0)),"^",12) Q:'$D(RAPUR(RAIMAG)) W:RACRT "."
- ..K RARP S RARPTNP=$G(^RARPT(RARPT,"NOPURGE")) I $S('$D(^RARPT(RARPT,0)):0,RAREPURG:1,'$D(^("PURGE")):1,1:0),RARPTNP'="n","RBA"[RAPURTYP D
- ... Q:+$O(^RARPT(RARPT,"ERR",0)) ; quit if report amended
- ...I $P(RAPUR(RAIMAG),"^",2)>RADTE,$D(^RARPT(RARPT,"R")) K ^("R") S RARP=""
- ...I $P(RAPUR(RAIMAG),"^")>RADTE,$D(^RARPT(RARPT,"L")) K ^("L") S RARP=""
- ...I $P(RAPUR(RAIMAG),"^",3)>RADTE,$D(^RARPT(RARPT,"H")) K ^("H") S RARP=""
- ..S:$D(RARP) ^RARPT(RARPT,"PURGE")=DT,$P(RAPUR(RAIMAG),"^",7)=$P(RAPUR(RAIMAG),"^",7)+1
- ..K RAEX I $S(RAREPURG:1,'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PURGE")):1,1:0),"EBA"[RAPURTYP D
- ...I $P(RAPUR(RAIMAG),"^")>RADTE,$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L")) K ^("L") S RAEX=""
- ...I $P(RAPUR(RAIMAG),"^",3)>RADTE,$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H")) K ^("H") S RAEX=""
- ...I $P(RAPUR(RAIMAG),"^",4)>RADTE,$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"T")) K ^("T") S RAEX=""
- ..S:$D(RAEX) ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PURGE")=DT,$P(RAPUR(RAIMAG),"^",6)=$P(RAPUR(RAIMAG),"^",6)+1
- ;
- ORDER ;Purge order/request data
- I "OA"'[RAPURTYP G STAT
- W !,"Purging orders/requests.",!
- S RAPKG="" F RAODTE=0:0 S RAODTE=$O(^RAO(75.1,"AO",RAODTE)) Q:'RAODTE!(RAODTE>RAODT) F RAOIFN=0:0 S RAOIFN=$O(^RAO(75.1,"AO",RAODTE,RAOIFN)) Q:'RAOIFN S RAORD0=$G(^RAO(75.1,RAOIFN,0)),RAIMAG=+$P(RAORD0,"^",3) D
- .I $D(RAPUR(RAIMAG)),$P(RAORD0,"^",5)<6 S RAPUROK=$$PUROK(RAORD0,DT) D:RAPUROK ENPUR
- ;
- ;Update statistics in Imaging Type file (#79.2)
- STAT D NOW^%DTC S Y=% K %,%H,%I W !,"Data purge completed at " D D^RAUTL W Y,".",!!,"The following purge statistics were compiled:"
- K RAX S RAX="" F S RAX=$O(RAPUR(RAX)) Q:'RAX S DA=RAX,DIE="^RA(79.2,",DR="100///""NOW""",DR(2,79.23)="2///P;3////"_DUZ_";4///"_$P(RAPUR(RAX),U,6)_";5///"_$P(RAPUR(RAX),"^",7)_";6///"_$P(RAPUR(RAX),"^",8) D ^DIE D
- .W !!,"Imaging Type: ",$P($G(^RA(79.2,RAX,0)),"^"),!
- .W !?5,"No. of exam records processed : ",$P(RAPUR(RAX),"^",6)
- .W !?5,"No. of reports processed : ",$P(RAPUR(RAX),"^",7)
- .W !?5,"No. of requests processed : ",$P(RAPUR(RAX),"^",8)
- EXIT K %DT,%T,D,D0,D1,DA,DDER,DE,DI,DIC,DIE,DQ,DR,DLAYGO,POP,RA0,RACN,RACNI
- K RACRT,RADFN,RADT,RADTE,RADTI,RAEX,RAI,RAIEN,RAIMAG,RAODT,RAODTE
- K RAOIFN,RAORD0,RAPKG,RAPOP,RAPUR,RAREPURG,RARP,RARPT,RARPTNP,RAX,X
- K RAGO,RAPURTYP
- K X1,X2,Y K:$G(RAORD)'="Z@" RAPUROK ; don't kill if entering through
- ; the front door & version of CPRS >2.5 RAPUROK checked in RAO7RO
- D CLOSE^RAUTL
- Q
- ;
- ENPUR ;OE/RR Entry Point for the PURGE ACTION Option
- I '$D(RAPKG),($$ORVR^RAORDU()=2.5) Q:'$D(ORPK)!('$D(ORSTS)) S OREND=$S(ORSTS<6:0,1:1) Q:OREND!(ORPK'>0) S RAOIFN=+ORPK
- ;
- ; The 'DELORD' subroutine deletes the Imaging Order data
- ; (field 11) in the 70.03 sub-file. This code handles deletions
- ; for parent procedures as well as orphan procedures (non-parent).
- ;
- D DELORD(RAOIFN,+$G(RAORD0)) ; +$G(RAORD0) is the patient dfn
- I $D(RAPKG) D ; track the # of requests processed
- . W:RACRT "." S $P(RAPUR(RAIMAG),"^",8)=$P(RAPUR(RAIMAG),"^",8)+1
- . Q
- I $$ORVR^RAORDU()=2.5 D
- . I $D(RAPKG) S ORIFN=+$P(RAORD0,"^",7),ORSTS="K" D:ORIFN ST^ORX K ORIFN,ORSTS
- . I '$D(RAPKG) S ORSTS="K" D:ORIFN ST^ORX K ORIFN,ORSTS
- . Q
- K %,DA,DIC,DIK
- D:$$ORVR^RAORDU()'<3&($G(RAORD)'="Z@") EN1^RAO7PURG(RAOIFN)
- ; do EN1^RAO7PURG only if we are going through the 'backdoor' for
- ; versions of CPRS 3.0 or greater.
- S DA=RAOIFN,DIK="^RAO(75.1," D ^DIK ; delete the order record
- K %,DA,DIC,DIK
- Q
- DELORD(RAOIFN,RADFN) ; Delete all of the imaging order pointers that refer
- ; to a specific order.
- ; input: raoifn-ien of our order in file 75.1
- ; radfn-ien of the patient associated with the order
- N RACNI,RADTI,X,Y S RADTI=0
- F S RADTI=$O(^RADPT("AO",RAOIFN,RADFN,RADTI)) Q:RADTI'>0 D
- . S RACNI=0
- . F S RACNI=$O(^RADPT("AO",RAOIFN,RADFN,RADTI,RACNI)) Q:RACNI'>0 D
- .. K %,D,D0,DA,DIC,DIE,DQ,DR
- .. S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DR="11///@"
- .. S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
- .. D ^DIE K %,D,D0,DA,DIC,DIE,DQ,DR
- .. Q
- . Q
- Q
- PUROK(RAORD0,RATDAY) ; Determine if an order meets the criteria
- ; to be purged from the Rad/Nuc Med Orders file.
- ; Input: RAORD0-0 node of the order record from file 75.1
- ; : RATDAY-the current date w/o time
- ; Output: 1 if the order meets the purge criteria, else 0
- N RAOSTAT S RAOSTAT=$P(RAORD0,"^",5)
- ;
- ; PENDING & ('Date Desired' -or- 'Sheduled Date' >= today), don't purge
- Q:RAOSTAT=5&(($P(RAORD0,"^",21)\1)'<RATDAY) 0 ; Date Desired
- Q:RAOSTAT=5&(($P(RAORD0,"^",23)\1)'<RATDAY) 0 ; Sch'ld date
- ; HOLD & ('Date Desired' -or- 'Sheduled Date' >= today), don't purge
- Q:RAOSTAT=3&(($P(RAORD0,"^",21)\1)'<RATDAY) 0 ; Date Desired
- Q:RAOSTAT=3&(($P(RAORD0,"^",23)\1)'<RATDAY) 0 ; Sch'ld date
- ;
- ; PENDING & 'Request Entered Date/Time' < than 1 year ago, don't purge
- I RAOSTAT=5,($P(RAORD0,"^",16)) Q:$P(RAORD0,"^",16)'<($$FMADD^XLFDT(RATDAY,-365)) 0
- ; HOLD & 'Request Entered Date/Time' < than 1 year ago, don't purge
- I RAOSTAT=3,($P(RAORD0,"^",16)) Q:$P(RAORD0,"^",16)'<($$FMADD^XLFDT(RATDAY,-365)) 0
- ; Orders that are in a status of: DISCONTINUED or COMPLETE are purged
- ; when they have no activity after the cut-off date for their img type
- Q 1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPURGE1 6621 printed Feb 19, 2025@00:05:17 Page 2
- RAPURGE1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Purge Rad/NM Data ;9/3/97 12:22
- +1 ;;5.0;Radiology/Nuclear Medicine;**34**;Mar 16, 1998
- START IF $GET(RAPURTYP)=""
- USE IO
- WRITE !,"RAPURTYP undefined or null, Purge Not Done."
- GOTO EXIT
- +1 USE IO
- DO NOW^%DTC
- SET Y=%
- SET RACRT=$EXTRACT(IOST,1,2)="C-"
- KILL %,%H,%I
- WRITE !!,"Purge data routine started at "
- DO D^RAUTL
- WRITE Y,"."
- +2 ;Set up variables needed for purge of selected imaging types
- +3 if '$ORDER(RAPUR(0))
- GOTO EXIT
- +4 SET (RADT,RAODT,RAIEN)=0
- FOR
- SET RAIEN=$ORDER(RAPUR(RAIEN))
- if 'RAIEN
- QUIT
- SET RAX=$GET(^RA(79.2,RAIEN,.1))
- Begin DoDot:1
- +5 FOR RAI=1:1:4
- SET X2=-$SELECT($PIECE(RAX,U,RAI)>89:$PIECE(RAX,U,RAI),1:27393)
- SET X1=DT
- DO C^%DTC
- SET $PIECE(RAPUR(RAIEN),"^",RAI)=X
- if X>RADT
- SET RADT=X
- +6 SET X2=-$SELECT($PIECE(RAX,U,6)>29:$PIECE(RAX,U,6),1:27393)
- SET X1=DT
- DO C^%DTC
- SET $PIECE(RAPUR(RAIEN),"^",5)=X
- if X>RAODT
- SET RAODT=X
- +7 FOR RAI=6:1:8
- SET $PIECE(RAPUR(RAIEN),"^",RAI)=0
- End DoDot:1
- +8 ;
- EXAM ;Purge exam/report data
- +1 IF RAPURTYP="O"
- GOTO ORDER
- +2 WRITE !!,"Purging exams/reports.",!
- +3 FOR RADTE=0:0
- SET RADTE=$ORDER(^RADPT("AR",RADTE))
- if RADTE'>0!(RADTE>RADT)
- QUIT
- SET RADTI=9999999.9999-RADTE
- FOR RADFN=0:0
- SET RADFN=$ORDER(^RADPT("AR",RADTE,RADFN))
- if RADFN'>0
- QUIT
- Begin DoDot:1
- +4 FOR RACN=0:0
- SET RACN=$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",RACN))
- if RACN'>0
- QUIT
- SET RACNI=+$ORDER(^(RACN,0))
- SET RA0=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
- SET RARPT=+$PIECE(RA0,"^",17)
- if $SELECT('$DATA(^("NOPURGE"))
- Begin DoDot:2
- +5 SET RAIMAG=+$PIECE($GET(^RAMIS(71,+$PIECE(RA0,"^",2),0)),"^",12)
- if '$DATA(RAPUR(RAIMAG))
- QUIT
- if RACRT
- WRITE "."
- +6 KILL RARP
- SET RARPTNP=$GET(^RARPT(RARPT,"NOPURGE"))
- IF $SELECT('$DATA(^RARPT(RARPT,0)):0,RAREPURG:1,'$DATA(^("PURGE")):1,1:0)
- IF RARPTNP'="n"
- IF "RBA"[RAPURTYP
- Begin DoDot:3
- +7 ; quit if report amended
- if +$ORDER(^RARPT(RARPT,"ERR",0))
- QUIT
- +8 IF $PIECE(RAPUR(RAIMAG),"^",2)>RADTE
- IF $DATA(^RARPT(RARPT,"R"))
- KILL ^("R")
- SET RARP=""
- +9 IF $PIECE(RAPUR(RAIMAG),"^")>RADTE
- IF $DATA(^RARPT(RARPT,"L"))
- KILL ^("L")
- SET RARP=""
- +10 IF $PIECE(RAPUR(RAIMAG),"^",3)>RADTE
- IF $DATA(^RARPT(RARPT,"H"))
- KILL ^("H")
- SET RARP=""
- End DoDot:3
- +11 if $DATA(RARP)
- SET ^RARPT(RARPT,"PURGE")=DT
- SET $PIECE(RAPUR(RAIMAG),"^",7)=$PIECE(RAPUR(RAIMAG),"^",7)+1
- +12 KILL RAEX
- IF $SELECT(RAREPURG:1,'$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PURGE")):1,1:0)
- IF "EBA"[RAPURTYP
- Begin DoDot:3
- +13 IF $PIECE(RAPUR(RAIMAG),"^")>RADTE
- IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L"))
- KILL ^("L")
- SET RAEX=""
- +14 IF $PIECE(RAPUR(RAIMAG),"^",3)>RADTE
- IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H"))
- KILL ^("H")
- SET RAEX=""
- +15 IF $PIECE(RAPUR(RAIMAG),"^",4)>RADTE
- IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"T"))
- KILL ^("T")
- SET RAEX=""
- End DoDot:3
- +16 if $DATA(RAEX)
- SET ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PURGE")=DT
- SET $PIECE(RAPUR(RAIMAG),"^",6)=$PIECE(RAPUR(RAIMAG),"^",6)+1
- End DoDot:2
- End DoDot:1
- +17 ;
- ORDER ;Purge order/request data
- +1 IF "OA"'[RAPURTYP
- GOTO STAT
- +2 WRITE !,"Purging orders/requests.",!
- +3 SET RAPKG=""
- FOR RAODTE=0:0
- SET RAODTE=$ORDER(^RAO(75.1,"AO",RAODTE))
- if 'RAODTE!(RAODTE>RAODT)
- QUIT
- FOR RAOIFN=0:0
- SET RAOIFN=$ORDER(^RAO(75.1,"AO",RAODTE,RAOIFN))
- if 'RAOIFN
- QUIT
- SET RAORD0=$GET(^RAO(75.1,RAOIFN,0))
- SET RAIMAG=+$PIECE(RAORD0,"^",3)
- Begin DoDot:1
- +4 IF $DATA(RAPUR(RAIMAG))
- IF $PIECE(RAORD0,"^",5)<6
- SET RAPUROK=$$PUROK(RAORD0,DT)
- if RAPUROK
- DO ENPUR
- End DoDot:1
- +5 ;
- +6 ;Update statistics in Imaging Type file (#79.2)
- STAT DO NOW^%DTC
- SET Y=%
- KILL %,%H,%I
- WRITE !,"Data purge completed at "
- DO D^RAUTL
- WRITE Y,".",!!,"The following purge statistics were compiled:"
- +1 KILL RAX
- SET RAX=""
- FOR
- SET RAX=$ORDER(RAPUR(RAX))
- if 'RAX
- QUIT
- SET DA=RAX
- SET DIE="^RA(79.2,"
- SET DR="100///""NOW"""
- SET DR(2,79.23)="2///P;3////"_DUZ_";4///"_$PIECE(RAPUR(RAX),U,6)_";5///"_$PIECE(RAPUR(RAX),"^",7)_";6///"_$PIECE(RAPUR(RAX),"^",8)
- DO ^DIE
- Begin DoDot:1
- +2 WRITE !!,"Imaging Type: ",$PIECE($GET(^RA(79.2,RAX,0)),"^"),!
- +3 WRITE !?5,"No. of exam records processed : ",$PIECE(RAPUR(RAX),"^",6)
- +4 WRITE !?5,"No. of reports processed : ",$PIECE(RAPUR(RAX),"^",7)
- +5 WRITE !?5,"No. of requests processed : ",$PIECE(RAPUR(RAX),"^",8)
- End DoDot:1
- EXIT KILL %DT,%T,D,D0,D1,DA,DDER,DE,DI,DIC,DIE,DQ,DR,DLAYGO,POP,RA0,RACN,RACNI
- +1 KILL RACRT,RADFN,RADT,RADTE,RADTI,RAEX,RAI,RAIEN,RAIMAG,RAODT,RAODTE
- +2 KILL RAOIFN,RAORD0,RAPKG,RAPOP,RAPUR,RAREPURG,RARP,RARPT,RARPTNP,RAX,X
- +3 KILL RAGO,RAPURTYP
- +4 ; don't kill if entering through
- KILL X1,X2,Y
- if $GET(RAORD)'="Z@"
- KILL RAPUROK
- +5 ; the front door & version of CPRS >2.5 RAPUROK checked in RAO7RO
- +6 DO CLOSE^RAUTL
- +7 QUIT
- +8 ;
- ENPUR ;OE/RR Entry Point for the PURGE ACTION Option
- +1 IF '$DATA(RAPKG)
- IF ($$ORVR^RAORDU()=2.5)
- if '$DATA(ORPK)!('$DATA(ORSTS))
- QUIT
- SET OREND=$SELECT(ORSTS<6:0,1:1)
- if OREND!(ORPK'>0)
- QUIT
- SET RAOIFN=+ORPK
- +2 ;
- +3 ; The 'DELORD' subroutine deletes the Imaging Order data
- +4 ; (field 11) in the 70.03 sub-file. This code handles deletions
- +5 ; for parent procedures as well as orphan procedures (non-parent).
- +6 ;
- +7 ; +$G(RAORD0) is the patient dfn
- DO DELORD(RAOIFN,+$GET(RAORD0))
- +8 ; track the # of requests processed
- IF $DATA(RAPKG)
- Begin DoDot:1
- +9 if RACRT
- WRITE "."
- SET $PIECE(RAPUR(RAIMAG),"^",8)=$PIECE(RAPUR(RAIMAG),"^",8)+1
- +10 QUIT
- End DoDot:1
- +11 IF $$ORVR^RAORDU()=2.5
- Begin DoDot:1
- +12 IF $DATA(RAPKG)
- SET ORIFN=+$PIECE(RAORD0,"^",7)
- SET ORSTS="K"
- if ORIFN
- DO ST^ORX
- KILL ORIFN,ORSTS
- +13 IF '$DATA(RAPKG)
- SET ORSTS="K"
- if ORIFN
- DO ST^ORX
- KILL ORIFN,ORSTS
- +14 QUIT
- End DoDot:1
- +15 KILL %,DA,DIC,DIK
- +16 if $$ORVR^RAORDU()'<3&($GET(RAORD)'="Z@")
- DO EN1^RAO7PURG(RAOIFN)
- +17 ; do EN1^RAO7PURG only if we are going through the 'backdoor' for
- +18 ; versions of CPRS 3.0 or greater.
- +19 ; delete the order record
- SET DA=RAOIFN
- SET DIK="^RAO(75.1,"
- DO ^DIK
- +20 KILL %,DA,DIC,DIK
- +21 QUIT
- DELORD(RAOIFN,RADFN) ; Delete all of the imaging order pointers that refer
- +1 ; to a specific order.
- +2 ; input: raoifn-ien of our order in file 75.1
- +3 ; radfn-ien of the patient associated with the order
- +4 NEW RACNI,RADTI,X,Y
- SET RADTI=0
- +5 FOR
- SET RADTI=$ORDER(^RADPT("AO",RAOIFN,RADFN,RADTI))
- if RADTI'>0
- QUIT
- Begin DoDot:1
- +6 SET RACNI=0
- +7 FOR
- SET RACNI=$ORDER(^RADPT("AO",RAOIFN,RADFN,RADTI,RACNI))
- if RACNI'>0
- QUIT
- Begin DoDot:2
- +8 KILL %,D,D0,DA,DIC,DIE,DQ,DR
- +9 SET DA(2)=RADFN
- SET DA(1)=RADTI
- SET DA=RACNI
- SET DR="11///@"
- +10 SET DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
- +11 DO ^DIE
- KILL %,D,D0,DA,DIC,DIE,DQ,DR
- +12 QUIT
- End DoDot:2
- +13 QUIT
- End DoDot:1
- +14 QUIT
- PUROK(RAORD0,RATDAY) ; Determine if an order meets the criteria
- +1 ; to be purged from the Rad/Nuc Med Orders file.
- +2 ; Input: RAORD0-0 node of the order record from file 75.1
- +3 ; : RATDAY-the current date w/o time
- +4 ; Output: 1 if the order meets the purge criteria, else 0
- +5 NEW RAOSTAT
- SET RAOSTAT=$PIECE(RAORD0,"^",5)
- +6 ;
- +7 ; PENDING & ('Date Desired' -or- 'Sheduled Date' >= today), don't purge
- +8 ; Date Desired
- if RAOSTAT=5&(($PIECE(RAORD0,"^",21)\1)'<RATDAY)
- QUIT 0
- +9 ; Sch'ld date
- if RAOSTAT=5&(($PIECE(RAORD0,"^",23)\1)'<RATDAY)
- QUIT 0
- +10 ; HOLD & ('Date Desired' -or- 'Sheduled Date' >= today), don't purge
- +11 ; Date Desired
- if RAOSTAT=3&(($PIECE(RAORD0,"^",21)\1)'<RATDAY)
- QUIT 0
- +12 ; Sch'ld date
- if RAOSTAT=3&(($PIECE(RAORD0,"^",23)\1)'<RATDAY)
- QUIT 0
- +13 ;
- +14 ; PENDING & 'Request Entered Date/Time' < than 1 year ago, don't purge
- +15 IF RAOSTAT=5
- IF ($PIECE(RAORD0,"^",16))
- if $PIECE(RAORD0,"^",16)'<($$FMADD^XLFDT(RATDAY,-365))
- QUIT 0
- +16 ; HOLD & 'Request Entered Date/Time' < than 1 year ago, don't purge
- +17 IF RAOSTAT=3
- IF ($PIECE(RAORD0,"^",16))
- if $PIECE(RAORD0,"^",16)'<($$FMADD^XLFDT(RATDAY,-365))
- QUIT 0
- +18 ; Orders that are in a status of: DISCONTINUED or COMPLETE are purged
- +19 ; when they have no activity after the cut-off date for their img type
- +20 QUIT 1