LRJPON ;ALB/JLC - OBSOLETE PENDING ORDERS;08/25/2010 12:32:47
;;5.2;LAB SERVICE;**425**;Sep 27, 1994;Build 30
;
;
; Reference to ^OR(100 supported by IA #3582
; Reference to STATUS^ORCSAVE2 supported by IA #5903
;
EN ;search for pending orders older than the obsolete (lapse) timeframe
N LRORD,LRDATE,LRSN,LRLAPSE,LRDATE,%,X1,X2,X,LRT,LRCANC,A1,A2,LRDUZ,X,DT,A,LRIFN,LRSTOP
S A1=$$GET^XPAR("SYS","LRJ OBSOLETE PENDING ORDERS",1,"I")
S A2=$P($G(^LAB(69.9,1,0)),"^",9)
I A1="",A2="" D MSG(1) Q
I A1="",A2]"" S X2=A2 D MSG(2,A2)
I A2="",A1]"" S X2=A1 D MSG(3,A1)
I A1]"",A2]"" I A1'<A2 D MSG(4,A1)
I A1]"",A2]"" S X2=$S(A1<A2:A1,A2<A1:A2,1:A1)
S X2="-"_X2,LRDUZ=$$PRXYUSR^LRUTIL3("HL",1)
D NOW^%DTC S (DT,X1)=$P(%,".") D C^%DTC S LRLAPSE=X
L +^LRJPON:$G(DILOCKTM,5) E Q
S LRDATE=0
F S LRDATE=$O(^LRO(69,LRDATE)) Q:'LRDATE Q:LRDATE>LRLAPSE D I $$REQ2STOP() S ZSTOP=1 Q
. S LRSN=0
. F S LRSN=$O(^LRO(69,LRDATE,1,LRSN)) Q:'LRSN D I $$REQ2STOP() Q
.. S A=$G(^LRO(69,LRDATE,1,LRSN,0)) I A="" Q
.. I $P(A,"^")="" Q
.. I $P($G(^LRO(69,LRDATE,1,LRSN,1)),"^")]"" Q
.. S (LRT,LRSTOP)=0
.. F S LRT=$O(^LRO(69,LRDATE,1,LRSN,2,LRT)) Q:'LRT D
... S A=$G(^LRO(69,LRDATE,1,LRSN,2,LRT,0)) I $P(A,"^",9)="CA" Q
... I $P(A,"^",6)]""!($P(A,"^",14)]"") S LRSTOP=$$CHECK(A,LRDATE,LRSN)
... S $P(^LRO(69,LRDATE,1,LRSN,2,LRT,0),"^",3,6)="^^^",$P(^(0),"^",9,11)="CA^L^"_LRDUZ
... I '$D(^LRO(69,LRDATE,1,LRSN,2,LRT,1.1,0)) S ^(0)="^^^^"_DT
... S X=1+$O(^LRO(69,LRDATE,1,LRSN,2,LRT,1.1,9999),-1)
... S $P(^LRO(69,LRDATE,1,LRSN,2,LRT,1.1,0),"^",3,4)=X_"^"_X,^(X,0)="Obsolete Order"
... I 'LRSTOP S LRIFN=$P($G(^LRO(69,LRDATE,1,LRSN,2,LRT,0)),"^",7) I LRIFN]"" D STATUS^ORCSAVE2(LRIFN,14)
.. D NEW^LR7OB1(LRDATE,LRSN,"Z@")
S $P(^LAB(69.9,1,64.9104),"^")=$P($$NOW^XLFDT,".")
L -^LRJPON
Q
;
CHECK(PREV,LDATE,LSN) ;
N B,LRCOM,ORIFN
S ORIFN=$P(PREV,"^",7) I ORIFN="" Q 1
I $P($G(^OR(100,ORIFN,3)),"^",3)'=5 Q 1
S B=$G(^OR(100,ORIFN,4)) I LDATE'=$P(B,";",2)!(LSN'=$P(B,";",3)) Q 1
Q 0
REQ2STOP() ;
; Check for task stop request
; Returns 1 if stop request made.
N STATUS,X
S STATUS=0
I '$D(ZTQUEUED) Q 0
S X=$$S^%ZTLOAD()
I X D ;
. S (STATUS,ZTSTOP)=1
. S X=$$S^%ZTLOAD("Received shutdown request")
;
I $Q Q STATUS
Q
;
MSG(ERR,DAYS) ;send mail message
K XMY N XMDUZ,XMSUB,XMTEXT,A
S XMDUZ="ORDERS, OBSOLETE",XMY("G.LMI")="",XMSUB="OBSOLETE ORDER PARAMETER(S) ISSUE"
I ERR=1 D
. S A(1)="Both the GRACE PERIOD FOR ORDERS field in file 69.9 and the LRJ OBSOLETE"
. S A(2)="PENDING ORDERS parameter are blank."
. S A(3)=" "
. S A(4)="One of these fields must be populated in order for the process to obsolete"
. S A(5)="pending orders to run."
I ERR=2!(ERR=3) D
. S A(1)="The "_$S(ERR=2:"LRJ OBSOLETE PENDING ORDERS parameter",1:"GRACE PERIOD FOR ORDERS field")_" is blank."
. S A(2)=" "
. S A(3)="The value: "_DAYS_" days was used for determining the 'obsolete' date."
I ERR=4 D
. S A(1)="The LRJ OBSOLETE PENDING ORDERS parameter is currently set to "_DAYS_"."
. S A(2)=" "
. S A(3)="This is either the same or greater than the GRACE PERIOD FOR ORDERS field in"
. S A(4)="file 69.9. LRJ OBSOLETE PENDING ORDERS should always be less."
. S A(5)=" "
. S A(6)="Please correct these settings. You may have to contact IRM for help changing"
. S A(7)="the parameter."
S XMTEXT="A(" D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRJPON 3418 printed Nov 22, 2024@17:25:37 Page 2
LRJPON ;ALB/JLC - OBSOLETE PENDING ORDERS;08/25/2010 12:32:47
+1 ;;5.2;LAB SERVICE;**425**;Sep 27, 1994;Build 30
+2 ;
+3 ;
+4 ; Reference to ^OR(100 supported by IA #3582
+5 ; Reference to STATUS^ORCSAVE2 supported by IA #5903
+6 ;
EN ;search for pending orders older than the obsolete (lapse) timeframe
+1 NEW LRORD,LRDATE,LRSN,LRLAPSE,LRDATE,%,X1,X2,X,LRT,LRCANC,A1,A2,LRDUZ,X,DT,A,LRIFN,LRSTOP
+2 SET A1=$$GET^XPAR("SYS","LRJ OBSOLETE PENDING ORDERS",1,"I")
+3 SET A2=$PIECE($GET(^LAB(69.9,1,0)),"^",9)
+4 IF A1=""
IF A2=""
DO MSG(1)
QUIT
+5 IF A1=""
IF A2]""
SET X2=A2
DO MSG(2,A2)
+6 IF A2=""
IF A1]""
SET X2=A1
DO MSG(3,A1)
+7 IF A1]""
IF A2]""
IF A1'<A2
DO MSG(4,A1)
+8 IF A1]""
IF A2]""
SET X2=$SELECT(A1<A2:A1,A2<A1:A2,1:A1)
+9 SET X2="-"_X2
SET LRDUZ=$$PRXYUSR^LRUTIL3("HL",1)
+10 DO NOW^%DTC
SET (DT,X1)=$PIECE(%,".")
DO C^%DTC
SET LRLAPSE=X
+11 LOCK +^LRJPON:$GET(DILOCKTM,5)
IF '$TEST
QUIT
+12 SET LRDATE=0
+13 FOR
SET LRDATE=$ORDER(^LRO(69,LRDATE))
if 'LRDATE
QUIT
if LRDATE>LRLAPSE
QUIT
Begin DoDot:1
+14 SET LRSN=0
+15 FOR
SET LRSN=$ORDER(^LRO(69,LRDATE,1,LRSN))
if 'LRSN
QUIT
Begin DoDot:2
+16 SET A=$GET(^LRO(69,LRDATE,1,LRSN,0))
IF A=""
QUIT
+17 IF $PIECE(A,"^")=""
QUIT
+18 IF $PIECE($GET(^LRO(69,LRDATE,1,LRSN,1)),"^")]""
QUIT
+19 SET (LRT,LRSTOP)=0
+20 FOR
SET LRT=$ORDER(^LRO(69,LRDATE,1,LRSN,2,LRT))
if 'LRT
QUIT
Begin DoDot:3
+21 SET A=$GET(^LRO(69,LRDATE,1,LRSN,2,LRT,0))
IF $PIECE(A,"^",9)="CA"
QUIT
+22 IF $PIECE(A,"^",6)]""!($PIECE(A,"^",14)]"")
SET LRSTOP=$$CHECK(A,LRDATE,LRSN)
+23 SET $PIECE(^LRO(69,LRDATE,1,LRSN,2,LRT,0),"^",3,6)="^^^"
SET $PIECE(^(0),"^",9,11)="CA^L^"_LRDUZ
+24 IF '$DATA(^LRO(69,LRDATE,1,LRSN,2,LRT,1.1,0))
SET ^(0)="^^^^"_DT
+25 SET X=1+$ORDER(^LRO(69,LRDATE,1,LRSN,2,LRT,1.1,9999),-1)
+26 SET $PIECE(^LRO(69,LRDATE,1,LRSN,2,LRT,1.1,0),"^",3,4)=X_"^"_X
SET ^(X,0)="Obsolete Order"
+27 IF 'LRSTOP
SET LRIFN=$PIECE($GET(^LRO(69,LRDATE,1,LRSN,2,LRT,0)),"^",7)
IF LRIFN]""
DO STATUS^ORCSAVE2(LRIFN,14)
End DoDot:3
+28 DO NEW^LR7OB1(LRDATE,LRSN,"Z@")
End DoDot:2
IF $$REQ2STOP()
QUIT
End DoDot:1
IF $$REQ2STOP()
SET ZSTOP=1
QUIT
+29 SET $PIECE(^LAB(69.9,1,64.9104),"^")=$PIECE($$NOW^XLFDT,".")
+30 LOCK -^LRJPON
+31 QUIT
+32 ;
CHECK(PREV,LDATE,LSN) ;
+1 NEW B,LRCOM,ORIFN
+2 SET ORIFN=$PIECE(PREV,"^",7)
IF ORIFN=""
QUIT 1
+3 IF $PIECE($GET(^OR(100,ORIFN,3)),"^",3)'=5
QUIT 1
+4 SET B=$GET(^OR(100,ORIFN,4))
IF LDATE'=$PIECE(B,";",2)!(LSN'=$PIECE(B,";",3))
QUIT 1
+5 QUIT 0
REQ2STOP() ;
+1 ; Check for task stop request
+2 ; Returns 1 if stop request made.
+3 NEW STATUS,X
+4 SET STATUS=0
+5 IF '$DATA(ZTQUEUED)
QUIT 0
+6 SET X=$$S^%ZTLOAD()
+7 ;
IF X
Begin DoDot:1
+8 SET (STATUS,ZTSTOP)=1
+9 SET X=$$S^%ZTLOAD("Received shutdown request")
End DoDot:1
+10 ;
+11 IF $QUIT
QUIT STATUS
+12 QUIT
+13 ;
MSG(ERR,DAYS) ;send mail message
+1 KILL XMY
NEW XMDUZ,XMSUB,XMTEXT,A
+2 SET XMDUZ="ORDERS, OBSOLETE"
SET XMY("G.LMI")=""
SET XMSUB="OBSOLETE ORDER PARAMETER(S) ISSUE"
+3 IF ERR=1
Begin DoDot:1
+4 SET A(1)="Both the GRACE PERIOD FOR ORDERS field in file 69.9 and the LRJ OBSOLETE"
+5 SET A(2)="PENDING ORDERS parameter are blank."
+6 SET A(3)=" "
+7 SET A(4)="One of these fields must be populated in order for the process to obsolete"
+8 SET A(5)="pending orders to run."
End DoDot:1
+9 IF ERR=2!(ERR=3)
Begin DoDot:1
+10 SET A(1)="The "_$SELECT(ERR=2:"LRJ OBSOLETE PENDING ORDERS parameter",1:"GRACE PERIOD FOR ORDERS field")_" is blank."
+11 SET A(2)=" "
+12 SET A(3)="The value: "_DAYS_" days was used for determining the 'obsolete' date."
End DoDot:1
+13 IF ERR=4
Begin DoDot:1
+14 SET A(1)="The LRJ OBSOLETE PENDING ORDERS parameter is currently set to "_DAYS_"."
+15 SET A(2)=" "
+16 SET A(3)="This is either the same or greater than the GRACE PERIOD FOR ORDERS field in"
+17 SET A(4)="file 69.9. LRJ OBSOLETE PENDING ORDERS should always be less."
+18 SET A(5)=" "
+19 SET A(6)="Please correct these settings. You may have to contact IRM for help changing"
+20 SET A(7)="the parameter."
End DoDot:1
+21 SET XMTEXT="A("
DO ^XMD
+22 QUIT
