- 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 Jan 18, 2025@03:16:15 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