LA7PURG ;DALOI/JMC - Purge Lab Messaging Interface Messages ;05/07/10 14:13
;;5.2;AUTOMATED LAB INSTRUMENTS;**27,64,74**;Sep 27, 1994;Build 229
;
; This routine purges messages and checks file intregrity for Lab Messaging.
Q
;
;
EN ; Entry point from taskman
D DQ^LA7CHKF
D PURGE,PSM,PLPO
S X=$$LACHK^LA7CHKF
Q
;
;
PURGE ; purge messages previous to today
N DA,DIK,I,LA7CFG,LA7DA,LA7DAT,LA7ROOT,LA7Q,X,Y
;
; Get each configuration's grace period for messages.
; Determine cut-off date for purging this configuration.
S I=0
F S I=$O(^LAHM(62.48,I)) Q:'I D
. S X=$P($G(^LAHM(62.48,I,0)),"^",6)
. I 'X S X=3 ; If missing, default to 3 days.
. S LA7DAT(I)=$$HTFM^XLFDT($$HADD^XLFDT($H,-X),1)
S LA7DAT=0
;
F S LA7DAT=$O(^LAHM(62.49,"AD",LA7DAT)) Q:'LA7DAT!(LA7DAT=DT) D
. ; Set flag if "problem" messages for this date are purgeable --> have been removed from XTMP.
. S LA7DAT(0)=$G(^XTMP("LA7ERR^"_LA7DAT,0),0)
. S LA7DA=0
. F S LA7DA=$O(^LAHM(62.49,"AD",LA7DAT,LA7DA)) Q:'LA7DA D
. . L +^LAHM(62.49,LA7DA):1
. . I $T D
. . . I LA7DAT'=$P($P($G(^LAHM(62.49,LA7DA,0)),"^",5),".") D Q
. . . . ; Date in cross-reference does not match field #4, remove x-ref.
. . . . K ^LAHM(62.49,"AD",LA7DAT,LA7DA)
. . . ; Don't purge if problem message and still in XTMP global.
. . . I LA7DAT(0),$P(^LAHM(62.49,LA7DA,0),"^",3)'="X" Q
. . . ; Get configuration for this message.
. . . S LA7CFG=+$G(^LAHM(62.49,LA7DA,.5))
. . . ; If message hasn't reached purge date --> skip.
. . . I LA7CFG,LA7DAT'<$G(LA7DAT(LA7CFG)) Q
. . . S DIK="^LAHM(62.49,",DA=LA7DA D ^DIK
. . L -^LAHM(62.49,LA7DA)
Q
;
;
PSM ; Purge shipping manifests file (#62.8)
;
; Check each manifest to determine if accessions on manifest have all
; been purged from file #68.
;
; If over 10000 entries purged from #62.85 then quit and pickup next
; session. Avoid performance and journaling issues.
N DA,DIK,LA7628,LA7CNT
S (LA7628,LA7CNT)=0,DIK="^LAHM(62.8,"
F S LA7628=$O(^LAHM(62.8,LA7628)) Q:'LA7628 D Q:LA7CNT>10000
. I '$$CHK628(LA7628) Q
. D P6285
. S DA=LA7628 D ^DIK
Q
;
;
PLPO ; Purge Lab Pending Orders file (#69.6)
;
; Check each order to determine if order can be purged.
;
; If over 5000 entries purged then quit and pickup next session.
; Avoid performance and journaling issues.
;
N DA,DIK,LA7696,LA7CNT,LA7COFF,LA7STAT
;
S DIK="^LRO(69.6,",(LA7696,LA7CNT)=0
; Cutoff dates
S LA7COFF(1)=$$FMADD^XLFDT(DT,-365),LA7COFF(2)=$$FMADD^XLFDT(DT,-730)
; Results sent status ien
S LA7STAT=$$FIND1^DIC(64.061,"","OMX","Results/data Received","","I $P(^LAB(64.061,Y,0),U,7)=""U""")
F S LA7696=$O(^LRO(69.6,LA7696)) Q:'LA7696 D Q:LA7CNT>5000
. I '$$CHK696(LA7696,.LA7COFF,LA7STAT) Q
. S LA7CNT=LA7CNT+1,DA=LA7696 D ^DIK
Q
;
;
CHK628(LA7628) ; If all accessions have been purged then safe to purge manifest
; and associated events (#62.85)
;
; Call with LA7628 = ien of manifest in #62.8
;
; Returns OK = 1(yes)/ 0(no) to purge
;
N LRUID,OK
S OK=1,LRUID=""
F S LRUID=$O(^LAHM(62.8,LA7628,10,"UID",LRUID)) Q:LRUID="" I $$CHECKUID^LRWU4(LRUID) S OK=0 Q
Q OK
;
;
P6285 ; Purge related entries in shipping activity log (#62.85)
;
N DA,DIK,LA7SM,LRUID
S LA7SM=$P(^LAHM(62.8,LA7628,0),"^"),LRUID="",DIK="^LAHM(62.85,"
;
; Purge entries in 62.85 relating to accessions (UID) on manifest
F S LRUID=$O(^LAHM(62.8,LA7628,10,"UID",LRUID)) Q:LRUID="" D
. S DA=0
. F S DA=$O(^LAHM(62.85,"AM",LRUID,LA7SM,DA)) Q:'DA D ^DIK S LA7CNT=LA7CNT+1
;
; Purge entries in 62.85 relating to manifest
S DA=0
F S DA=$O(^LAHM(62.85,"B",LA7SM,DA)) Q:'DA D ^DIK S LA7CNT=LA7CNT+1
Q
;
;
CHK696(LA7696,LA7COFF,LA7SPST) ; Check if order safe to purge
;
; Call with LA7696 = ien of order in #69.6
; LA7COFF = array of cutoff FileMan dates.
; LA7SPST = ien of specimen status Results/data Received
;
; Returns OK = 1(yes)/ 0(no) to purge
;
N LAX,OK
S OK=0,LAX=$G(^LRO(69.6,LA7696,1))
;
; Check date order completed
I $P(LAX,"^",7),$P(LAX,"^",7)<LA7COFF(1) S OK=1
;
; Check date order received/tranmsitted
I 'OK D
. I $P(LAX,"^",4),$P(LAX,"^",4)<LA7COFF(2) S OK=1 Q
. I $P(LAX,"^",5),$P(LAX,"^",5)<LA7COFF(2) S OK=1 Q
;
; Check date order received and specimen status
I 'OK,$P(LAX,"^",5),$P(LAX,"^",5)<LA7COFF(1) D
. S X=$P($G(^LRO(69.6,LA7696,0)),"^",10) ; specimen status
. I LA7SPST,X=LA7SPST S OK=1
;
Q OK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7PURG 4526 printed Apr 09, 2024@20:47:56 Page 2
LA7PURG ;DALOI/JMC - Purge Lab Messaging Interface Messages ;05/07/10 14:13
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,64,74**;Sep 27, 1994;Build 229
+2 ;
+3 ; This routine purges messages and checks file intregrity for Lab Messaging.
+4 QUIT
+5 ;
+6 ;
EN ; Entry point from taskman
+1 DO DQ^LA7CHKF
+2 DO PURGE
DO PSM
DO PLPO
+3 SET X=$$LACHK^LA7CHKF
+4 QUIT
+5 ;
+6 ;
PURGE ; purge messages previous to today
+1 NEW DA,DIK,I,LA7CFG,LA7DA,LA7DAT,LA7ROOT,LA7Q,X,Y
+2 ;
+3 ; Get each configuration's grace period for messages.
+4 ; Determine cut-off date for purging this configuration.
+5 SET I=0
+6 FOR
SET I=$ORDER(^LAHM(62.48,I))
if 'I
QUIT
Begin DoDot:1
+7 SET X=$PIECE($GET(^LAHM(62.48,I,0)),"^",6)
+8 ; If missing, default to 3 days.
IF 'X
SET X=3
+9 SET LA7DAT(I)=$$HTFM^XLFDT($$HADD^XLFDT($HOROLOG,-X),1)
End DoDot:1
+10 SET LA7DAT=0
+11 ;
+12 FOR
SET LA7DAT=$ORDER(^LAHM(62.49,"AD",LA7DAT))
if 'LA7DAT!(LA7DAT=DT)
QUIT
Begin DoDot:1
+13 ; Set flag if "problem" messages for this date are purgeable --> have been removed from XTMP.
+14 SET LA7DAT(0)=$GET(^XTMP("LA7ERR^"_LA7DAT,0),0)
+15 SET LA7DA=0
+16 FOR
SET LA7DA=$ORDER(^LAHM(62.49,"AD",LA7DAT,LA7DA))
if 'LA7DA
QUIT
Begin DoDot:2
+17 LOCK +^LAHM(62.49,LA7DA):1
+18 IF $TEST
Begin DoDot:3
+19 IF LA7DAT'=$PIECE($PIECE($GET(^LAHM(62.49,LA7DA,0)),"^",5),".")
Begin DoDot:4
+20 ; Date in cross-reference does not match field #4, remove x-ref.
+21 KILL ^LAHM(62.49,"AD",LA7DAT,LA7DA)
End DoDot:4
QUIT
+22 ; Don't purge if problem message and still in XTMP global.
+23 IF LA7DAT(0)
IF $PIECE(^LAHM(62.49,LA7DA,0),"^",3)'="X"
QUIT
+24 ; Get configuration for this message.
+25 SET LA7CFG=+$GET(^LAHM(62.49,LA7DA,.5))
+26 ; If message hasn't reached purge date --> skip.
+27 IF LA7CFG
IF LA7DAT'<$GET(LA7DAT(LA7CFG))
QUIT
+28 SET DIK="^LAHM(62.49,"
SET DA=LA7DA
DO ^DIK
End DoDot:3
+29 LOCK -^LAHM(62.49,LA7DA)
End DoDot:2
End DoDot:1
+30 QUIT
+31 ;
+32 ;
PSM ; Purge shipping manifests file (#62.8)
+1 ;
+2 ; Check each manifest to determine if accessions on manifest have all
+3 ; been purged from file #68.
+4 ;
+5 ; If over 10000 entries purged from #62.85 then quit and pickup next
+6 ; session. Avoid performance and journaling issues.
+7 NEW DA,DIK,LA7628,LA7CNT
+8 SET (LA7628,LA7CNT)=0
SET DIK="^LAHM(62.8,"
+9 FOR
SET LA7628=$ORDER(^LAHM(62.8,LA7628))
if 'LA7628
QUIT
Begin DoDot:1
+10 IF '$$CHK628(LA7628)
QUIT
+11 DO P6285
+12 SET DA=LA7628
DO ^DIK
End DoDot:1
if LA7CNT>10000
QUIT
+13 QUIT
+14 ;
+15 ;
PLPO ; Purge Lab Pending Orders file (#69.6)
+1 ;
+2 ; Check each order to determine if order can be purged.
+3 ;
+4 ; If over 5000 entries purged then quit and pickup next session.
+5 ; Avoid performance and journaling issues.
+6 ;
+7 NEW DA,DIK,LA7696,LA7CNT,LA7COFF,LA7STAT
+8 ;
+9 SET DIK="^LRO(69.6,"
SET (LA7696,LA7CNT)=0
+10 ; Cutoff dates
+11 SET LA7COFF(1)=$$FMADD^XLFDT(DT,-365)
SET LA7COFF(2)=$$FMADD^XLFDT(DT,-730)
+12 ; Results sent status ien
+13 SET LA7STAT=$$FIND1^DIC(64.061,"","OMX","Results/data Received","","I $P(^LAB(64.061,Y,0),U,7)=""U""")
+14 FOR
SET LA7696=$ORDER(^LRO(69.6,LA7696))
if 'LA7696
QUIT
Begin DoDot:1
+15 IF '$$CHK696(LA7696,.LA7COFF,LA7STAT)
QUIT
+16 SET LA7CNT=LA7CNT+1
SET DA=LA7696
DO ^DIK
End DoDot:1
if LA7CNT>5000
QUIT
+17 QUIT
+18 ;
+19 ;
CHK628(LA7628) ; If all accessions have been purged then safe to purge manifest
+1 ; and associated events (#62.85)
+2 ;
+3 ; Call with LA7628 = ien of manifest in #62.8
+4 ;
+5 ; Returns OK = 1(yes)/ 0(no) to purge
+6 ;
+7 NEW LRUID,OK
+8 SET OK=1
SET LRUID=""
+9 FOR
SET LRUID=$ORDER(^LAHM(62.8,LA7628,10,"UID",LRUID))
if LRUID=""
QUIT
IF $$CHECKUID^LRWU4(LRUID)
SET OK=0
QUIT
+10 QUIT OK
+11 ;
+12 ;
P6285 ; Purge related entries in shipping activity log (#62.85)
+1 ;
+2 NEW DA,DIK,LA7SM,LRUID
+3 SET LA7SM=$PIECE(^LAHM(62.8,LA7628,0),"^")
SET LRUID=""
SET DIK="^LAHM(62.85,"
+4 ;
+5 ; Purge entries in 62.85 relating to accessions (UID) on manifest
+6 FOR
SET LRUID=$ORDER(^LAHM(62.8,LA7628,10,"UID",LRUID))
if LRUID=""
QUIT
Begin DoDot:1
+7 SET DA=0
+8 FOR
SET DA=$ORDER(^LAHM(62.85,"AM",LRUID,LA7SM,DA))
if 'DA
QUIT
DO ^DIK
SET LA7CNT=LA7CNT+1
End DoDot:1
+9 ;
+10 ; Purge entries in 62.85 relating to manifest
+11 SET DA=0
+12 FOR
SET DA=$ORDER(^LAHM(62.85,"B",LA7SM,DA))
if 'DA
QUIT
DO ^DIK
SET LA7CNT=LA7CNT+1
+13 QUIT
+14 ;
+15 ;
CHK696(LA7696,LA7COFF,LA7SPST) ; Check if order safe to purge
+1 ;
+2 ; Call with LA7696 = ien of order in #69.6
+3 ; LA7COFF = array of cutoff FileMan dates.
+4 ; LA7SPST = ien of specimen status Results/data Received
+5 ;
+6 ; Returns OK = 1(yes)/ 0(no) to purge
+7 ;
+8 NEW LAX,OK
+9 SET OK=0
SET LAX=$GET(^LRO(69.6,LA7696,1))
+10 ;
+11 ; Check date order completed
+12 IF $PIECE(LAX,"^",7)
IF $PIECE(LAX,"^",7)<LA7COFF(1)
SET OK=1
+13 ;
+14 ; Check date order received/tranmsitted
+15 IF 'OK
Begin DoDot:1
+16 IF $PIECE(LAX,"^",4)
IF $PIECE(LAX,"^",4)<LA7COFF(2)
SET OK=1
QUIT
+17 IF $PIECE(LAX,"^",5)
IF $PIECE(LAX,"^",5)<LA7COFF(2)
SET OK=1
QUIT
End DoDot:1
+18 ;
+19 ; Check date order received and specimen status
+20 IF 'OK
IF $PIECE(LAX,"^",5)
IF $PIECE(LAX,"^",5)<LA7COFF(1)
Begin DoDot:1
+21 ; specimen status
SET X=$PIECE($GET(^LRO(69.6,LA7696,0)),"^",10)
+22 IF LA7SPST
IF X=LA7SPST
SET OK=1
End DoDot:1
+23 ;
+24 QUIT OK
