- 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
- ;
- 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 ;
