ORTASK01 ; SLC/RJS - Look for orders to purge; [1/2/01 11:44am]
;;3.0;ORDER ENTRY/RESULTS REPORTING;**98**;Dec 17, 1997
;
; QUIT added below by PKS (SLC) on 11/27/2000 to prevent potential
; for any sites using unfinished ORTASK PURGE as scheduled option:
;
Q
;
S ;
N ORCNT,ORT0,ORT3,ORTERR,ORTGRC,ORTNOW,ORTORD,ORTPDT,ORTRUN,X,%DT
;
I '$G(ZTSK) D HELP S ORTRUN=$$READ("Y","Want to run the purge now ","NO") Q:(ORTRUN[U) Q:('ORTRUN)
;
S ORTORD=$$GET^XPAR("ALL","ORPF LAST ORDER PURGED") S:(ORTORD<1) ORTORD=0
S ORTGRC=$$GET^XPAR("ALL","ORPF GRACE DAYS BEFORE PURGE") S:(ORTGRC<1) ORTGRC=90
S %DT="",X="T-"_ORTGRC D ^%DT S ORTPDT=+Y
S %DT="",X="T" D ^%DT S ORTNOW=+Y
;
S ORTERR=0 D F ORCNT=0:1 S ORTORD=$O(^OR(100,ORTORD)) Q:'ORTORD D Q:ORTERR
.Q:'ORTORD Q:ORTERR
.;
.D EN^XPAR("SYS","ORPF LAST ORDER PURGED",1,"`"_ORTORD,.ORTERR) Q:ORTERR
.;
.S ORT0=$G(^OR(100,ORTORD,0))
.S ORT3=$G(^OR(100,ORTORD,3))
.;
.Q:(ORTPDT<ORT3) ; DATE OF LAST ACTIVITY IS AFTER PURGE DATE
.;
.Q:(ORTNOW<$P(ORT0,U,8)) ; ORDER START DATE IS IN THE FUTURE
.;
.Q:'("^0^1^2^7^12^13^14^"[("^"_(+$P(ORT3,U,3))_"^")) ; LAST ACTIVITY STATUS IS NOT TERMINAL
.;
.Q:$P(ORT3,U,9) ; CHILD ORDER
.;
.D PURGE^ORMEVNT(ORTORD)
.;
;
D EN^XPAR("SYS","ORPF LAST ORDER PURGED",1,"",.ORTERR) Q:ORTERR
D PUT^XPAR("SYS","ORPF LAST PURGE DATE",1,DT,.ORTERR) Q:ORTERR
;
D:$G(ZTSK) KILL^%ZTLOAD
;
Q
;
HELP ;
N LINE,TEXT
W !!
F LINE=1:1:999 S TEXT=$P($T(HELPTEXT+LINE),";",2,999) Q:TEXT W !,$P(TEXT,";",2,999)
W !!
Q
;
HELPTEXT ;;
;; Option: ORTASK PURGE (Old Orders Batch Purge)
;;
;; This is a purge of all orders that have a 'Last Activity Date' of more
;; than the number of 'Grace days' ago. It also checks to make sure the
;; orders that are purged are 'Child' orders, have an order start date in
;; the past, and have a 'Terminal' status.
;;
;; As this option scans the entire Orders file, it should be sheduled to
;; run after hours.
;1;
;
READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
Q:'$L($G(OCXZ0)) U
S DIR(0)=OCXZ0
S:$L($G(OCXZA)) DIR("A")=OCXZA
S:$L($G(OCXZB)) DIR("B")=OCXZB
F OCXLINE=1:1:($G(OCXZL)-1) W !
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORTASK01 2426 printed Sep 23, 2025@20:10:37 Page 2
ORTASK01 ; SLC/RJS - Look for orders to purge; [1/2/01 11:44am]
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**98**;Dec 17, 1997
+2 ;
+3 ; QUIT added below by PKS (SLC) on 11/27/2000 to prevent potential
+4 ; for any sites using unfinished ORTASK PURGE as scheduled option:
+5 ;
+6 QUIT
+7 ;
S ;
+1 NEW ORCNT,ORT0,ORT3,ORTERR,ORTGRC,ORTNOW,ORTORD,ORTPDT,ORTRUN,X,%DT
+2 ;
+3 IF '$GET(ZTSK)
DO HELP
SET ORTRUN=$$READ("Y","Want to run the purge now ","NO")
if (ORTRUN[U)
QUIT
if ('ORTRUN)
QUIT
+4 ;
+5 SET ORTORD=$$GET^XPAR("ALL","ORPF LAST ORDER PURGED")
if (ORTORD<1)
SET ORTORD=0
+6 SET ORTGRC=$$GET^XPAR("ALL","ORPF GRACE DAYS BEFORE PURGE")
if (ORTGRC<1)
SET ORTGRC=90
+7 SET %DT=""
SET X="T-"_ORTGRC
DO ^%DT
SET ORTPDT=+Y
+8 SET %DT=""
SET X="T"
DO ^%DT
SET ORTNOW=+Y
+9 ;
+10 SET ORTERR=0
Begin DoDot:1
+11 if 'ORTORD
QUIT
if ORTERR
QUIT
+12 ;
+13 DO EN^XPAR("SYS","ORPF LAST ORDER PURGED",1,"`"_ORTORD,.ORTERR)
if ORTERR
QUIT
+14 ;
+15 SET ORT0=$GET(^OR(100,ORTORD,0))
+16 SET ORT3=$GET(^OR(100,ORTORD,3))
+17 ;
+18 ; DATE OF LAST ACTIVITY IS AFTER PURGE DATE
if (ORTPDT<ORT3)
QUIT
+19 ;
+20 ; ORDER START DATE IS IN THE FUTURE
if (ORTNOW<$PIECE(ORT0,U,8))
QUIT
+21 ;
+22 ; LAST ACTIVITY STATUS IS NOT TERMINAL
if '("^0^1^2^7^12^13^14^"[("^"_(+$PIECE(ORT3,U,3))_"^"))
QUIT
+23 ;
+24 ; CHILD ORDER
if $PIECE(ORT3,U,9)
QUIT
+25 ;
+26 DO PURGE^ORMEVNT(ORTORD)
+27 ;
End DoDot:1
FOR ORCNT=0:1
SET ORTORD=$ORDER(^OR(100,ORTORD))
if 'ORTORD
QUIT
Begin DoDot:1
End DoDot:1
if ORTERR
QUIT
+28 ;
+29 DO EN^XPAR("SYS","ORPF LAST ORDER PURGED",1,"",.ORTERR)
if ORTERR
QUIT
+30 DO PUT^XPAR("SYS","ORPF LAST PURGE DATE",1,DT,.ORTERR)
if ORTERR
QUIT
+31 ;
+32 if $GET(ZTSK)
DO KILL^%ZTLOAD
+33 ;
+34 QUIT
+35 ;
HELP ;
+1 NEW LINE,TEXT
+2 WRITE !!
+3 FOR LINE=1:1:999
SET TEXT=$PIECE($TEXT(HELPTEXT+LINE),";",2,999)
if TEXT
QUIT
WRITE !,$PIECE(TEXT,";",2,999)
+4 WRITE !!
+5 QUIT
+6 ;
HELPTEXT ;;
+1 ;; Option: ORTASK PURGE (Old Orders Batch Purge)
+2 ;;
+3 ;; This is a purge of all orders that have a 'Last Activity Date' of more
+4 ;; than the number of 'Grace days' ago. It also checks to make sure the
+5 ;; orders that are purged are 'Child' orders, have an order start date in
+6 ;; the past, and have a 'Terminal' status.
+7 ;;
+8 ;; As this option scans the entire Orders file, it should be sheduled to
+9 ;; run after hours.
+10 ;1;
+11 ;
READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
+1 NEW OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
+2 if '$LENGTH($GET(OCXZ0))
QUIT U
+3 SET DIR(0)=OCXZ0
+4 if $LENGTH($GET(OCXZA))
SET DIR("A")=OCXZA
+5 if $LENGTH($GET(OCXZB))
SET DIR("B")=OCXZB
+6 FOR OCXLINE=1:1:($GET(OCXZL)-1)
WRITE !
+7 DO ^DIR
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT U
+9 QUIT Y
+10 ;
