ORY24 ;SLC/MKB-Postinit for OR*3*24 ;4/16/98 16:18
;;3.0;ORDER ENTRY/RESULTS REPORTING;**24**;Dec 17, 1997
;
EN ; -- start here
N X S X=$$GET^XPAR("ALL","ORPF DC OF GENERIC ORDERS")
D:'$L(X) EN^XPAR("SYS","ORPF DC OF GENERIC ORDERS",1,2)
S X=$$GET^XPAR("ALL","OR DC GEN ORD ON ADMISSION")
D:'$L(X) EN^XPAR("SYS","OR DC GEN ORD ON ADMISSION",1,0)
Q
;
TASK ; -- start here to task status update
;
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK
S ZTDESC="Expire text orders more than 90 days old",ZTDTH=$H,ZTIO=""
S ZTRTN="EXP^ORY24" D ^%ZTLOAD
W !,"Task "_$S($G(ZTSK):"#"_ZTSK,1:"not")_" queued."
Q
;
EXP ; -- expire text orders more than 90 days old
N ORPKG,ORALG,ORNOW,OROLD,ORIFN,OR0,OR3,ORSTRT,ORSTOP,ORLAST
S ORPKG=+$O(^DIC(9.4,"C","OR",0)),ORALG=+$O(^DIC(9.4,"C","GMRA",0))
S ORNOW=$$NOW^XLFDT,OROLD=$$FMADD^XLFDT(ORNOW,-90),ORIFN=0
F S ORIFN=$O(^OR(100,ORIFN)) Q:ORIFN'>0 S OR0=$G(^(ORIFN,0)),OR3=$G(^(3)) I "^1^2^7^12^13^14^15^"'[(U_$P(OR3,U,3)_U) D ;still active
. S ORSTRT=$P(OR0,U,8),ORSTOP=$P(OR0,U,9),ORLAST=$P(OR3,U)
. I $P(OR0,U,14)=ORALG,ORSTRT,ORSTRT<OROLD D RESET(2,ORLAST) Q
. Q:$P(OR0,U,14)'=ORPKG ; ** generic orders only:
. I ORSTOP D:ORSTOP'>ORNOW RESET(7) S:ORSTOP>ORNOW ^OR(100,"AE",ORSTOP,ORIFN)="" Q
. I ORSTRT,ORSTRT<OROLD D RESET(7,ORLAST) Q
Q
;
RESET(NEWSTS,STOP) ; -- reset terminal fields for ORIFN
S:$G(NEWSTS) $P(^OR(100,ORIFN,3),U,3)=NEWSTS
S:$G(STOP) $P(^OR(100,ORIFN,0),U,9)=STOP
D SETALL^ORDD100(ORIFN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY24 1495 printed Nov 22, 2024@17:49:45 Page 2
ORY24 ;SLC/MKB-Postinit for OR*3*24 ;4/16/98 16:18
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**24**;Dec 17, 1997
+2 ;
EN ; -- start here
+1 NEW X
SET X=$$GET^XPAR("ALL","ORPF DC OF GENERIC ORDERS")
+2 if '$LENGTH(X)
DO EN^XPAR("SYS","ORPF DC OF GENERIC ORDERS",1,2)
+3 SET X=$$GET^XPAR("ALL","OR DC GEN ORD ON ADMISSION")
+4 if '$LENGTH(X)
DO EN^XPAR("SYS","OR DC GEN ORD ON ADMISSION",1,0)
+5 QUIT
+6 ;
TASK ; -- start here to task status update
+1 ;
+2 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK
+3 SET ZTDESC="Expire text orders more than 90 days old"
SET ZTDTH=$HOROLOG
SET ZTIO=""
+4 SET ZTRTN="EXP^ORY24"
DO ^%ZTLOAD
+5 WRITE !,"Task "_$SELECT($GET(ZTSK):"#"_ZTSK,1:"not")_" queued."
+6 QUIT
+7 ;
EXP ; -- expire text orders more than 90 days old
+1 NEW ORPKG,ORALG,ORNOW,OROLD,ORIFN,OR0,OR3,ORSTRT,ORSTOP,ORLAST
+2 SET ORPKG=+$ORDER(^DIC(9.4,"C","OR",0))
SET ORALG=+$ORDER(^DIC(9.4,"C","GMRA",0))
+3 SET ORNOW=$$NOW^XLFDT
SET OROLD=$$FMADD^XLFDT(ORNOW,-90)
SET ORIFN=0
+4 ;still active
FOR
SET ORIFN=$ORDER(^OR(100,ORIFN))
if ORIFN'>0
QUIT
SET OR0=$GET(^(ORIFN,0))
SET OR3=$GET(^(3))
IF "^1^2^7^12^13^14^15^"'[(U_$PIECE(OR3,U,3)_U)
Begin DoDot:1
+5 SET ORSTRT=$PIECE(OR0,U,8)
SET ORSTOP=$PIECE(OR0,U,9)
SET ORLAST=$PIECE(OR3,U)
+6 IF $PIECE(OR0,U,14)=ORALG
IF ORSTRT
IF ORSTRT<OROLD
DO RESET(2,ORLAST)
QUIT
+7 ; ** generic orders only:
if $PIECE(OR0,U,14)'=ORPKG
QUIT
+8 IF ORSTOP
if ORSTOP'>ORNOW
DO RESET(7)
if ORSTOP>ORNOW
SET ^OR(100,"AE",ORSTOP,ORIFN)=""
QUIT
+9 IF ORSTRT
IF ORSTRT<OROLD
DO RESET(7,ORLAST)
QUIT
End DoDot:1
+10 QUIT
+11 ;
RESET(NEWSTS,STOP) ; -- reset terminal fields for ORIFN
+1 if $GET(NEWSTS)
SET $PIECE(^OR(100,ORIFN,3),U,3)=NEWSTS
+2 if $GET(STOP)
SET $PIECE(^OR(100,ORIFN,0),U,9)=STOP
+3 DO SETALL^ORDD100(ORIFN)
+4 QUIT
