LRMLPRG ;BPFO/DTG - PURGE PGM FOR NTRT PROCESS ;02102016
;;5.2;LAB SERVICE;**468**;FEB 10 2016;Build 64
;
;purge routine for the audit date/time multiple in file 60
EN ; enter here from [LR NTRT EDIT PURGE]
N ZTDESC,ZTSAVE,ZTRTN,ZTDTH,ZTIO,ZTSK,LRDUZ
S LRDUZ=DUZ,ZTSAVE("LRDUZ")=""
S ZTDESC="LR NDS AUDITS PURGE"
S ZTRTN="QUEA^LRMLPRG",ZTDTH=$$NOW^XLFDT,ZTIO=""
D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
K ZTSK D HOME^%ZIS
Q
;
CALL ; from task manager
N ZTDESC,ZTSAVE,ZTRTN,ZTDTH,ZTSK,ZTIO
S ZTDESC="LR NTRT EDITS PURGE"
S ZTRTN="QUEA^LRMLPRG",ZTDTH=$$NOW^XLFDT
D ^%ZTLOAD
Q
;
QUEA ; walk ^LAB(60,,15 and trim older audits
N DA,DIE,DR,A,LD,LT,B,PS,PURGEDAYS,PDT,LDT,DIDEL
S U="^" I $G(DT)="" S DT=$$DT^XLFDT
S B=$$SITE^VASITE,B=$P(B,U,1) I 'B G QDONE ; not set up
S PS=$O(^LAB(66.4,"B",B,0)) I PS="" G QDONE ; 66.4 not set up
S PURGEDAYS=$$GET1^DIQ(66.4,PS_",",.04)
I PURGEDAYS=""!(+PURGEDAYS<1) S PURGEDAYS=220
S PDT=DT-PURGEDAYS
; loop ^LAB(60 audit date/time multiple
S LT=0
Q1 S LT=$O(^LAB(60,LT)) I 'LT G QDONE
S LD=0
Q2 S LD=$O(^LAB(60,LT,15,LD)) I 'LD G Q1
S A=$$GET1^DIQ(60.28,LD_","_LT,.01,"I") I A="" G Q2
S LDT=$P(A,".",1) I LDT>PDT G Q2
; remove entry from file
S DIDEL=60.28
L +^LAB(60,LT,15,LD):30 I '$T G Q2
S DA=LD,DA(1)=LT,DIE="^LAB(60,"_DA(1)_",15,",DR=".01///@"
D ^DIE
L -^LAB(60,LT,15,LD)
G Q2
;
QDONE K DA,DIE,DR,A,LD,LT,B,PS,PURGEDAYS,PDT,LDT,DIDEL
I $D(ZTQUEUED) S ZTREQ="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMLPRG 1498 printed Sep 23, 2025@19:53:38 Page 2
LRMLPRG ;BPFO/DTG - PURGE PGM FOR NTRT PROCESS ;02102016
+1 ;;5.2;LAB SERVICE;**468**;FEB 10 2016;Build 64
+2 ;
+3 ;purge routine for the audit date/time multiple in file 60
EN ; enter here from [LR NTRT EDIT PURGE]
+1 NEW ZTDESC,ZTSAVE,ZTRTN,ZTDTH,ZTIO,ZTSK,LRDUZ
+2 SET LRDUZ=DUZ
SET ZTSAVE("LRDUZ")=""
+3 SET ZTDESC="LR NDS AUDITS PURGE"
+4 SET ZTRTN="QUEA^LRMLPRG"
SET ZTDTH=$$NOW^XLFDT
SET ZTIO=""
+5 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Request Queued, #",ZTSK
WRITE !
+6 KILL ZTSK
DO HOME^%ZIS
+7 QUIT
+8 ;
CALL ; from task manager
+1 NEW ZTDESC,ZTSAVE,ZTRTN,ZTDTH,ZTSK,ZTIO
+2 SET ZTDESC="LR NTRT EDITS PURGE"
+3 SET ZTRTN="QUEA^LRMLPRG"
SET ZTDTH=$$NOW^XLFDT
+4 DO ^%ZTLOAD
+5 QUIT
+6 ;
QUEA ; walk ^LAB(60,,15 and trim older audits
+1 NEW DA,DIE,DR,A,LD,LT,B,PS,PURGEDAYS,PDT,LDT,DIDEL
+2 SET U="^"
IF $GET(DT)=""
SET DT=$$DT^XLFDT
+3 ; not set up
SET B=$$SITE^VASITE
SET B=$PIECE(B,U,1)
IF 'B
GOTO QDONE
+4 ; 66.4 not set up
SET PS=$ORDER(^LAB(66.4,"B",B,0))
IF PS=""
GOTO QDONE
+5 SET PURGEDAYS=$$GET1^DIQ(66.4,PS_",",.04)
+6 IF PURGEDAYS=""!(+PURGEDAYS<1)
SET PURGEDAYS=220
+7 SET PDT=DT-PURGEDAYS
+8 ; loop ^LAB(60 audit date/time multiple
+9 SET LT=0
Q1 SET LT=$ORDER(^LAB(60,LT))
IF 'LT
GOTO QDONE
+1 SET LD=0
Q2 SET LD=$ORDER(^LAB(60,LT,15,LD))
IF 'LD
GOTO Q1
+1 SET A=$$GET1^DIQ(60.28,LD_","_LT,.01,"I")
IF A=""
GOTO Q2
+2 SET LDT=$PIECE(A,".",1)
IF LDT>PDT
GOTO Q2
+3 ; remove entry from file
+4 SET DIDEL=60.28
+5 LOCK +^LAB(60,LT,15,LD):30
IF '$TEST
GOTO Q2
+6 SET DA=LD
SET DA(1)=LT
SET DIE="^LAB(60,"_DA(1)_",15,"
SET DR=".01///@"
+7 DO ^DIE
+8 LOCK -^LAB(60,LT,15,LD)
+9 GOTO Q2
+10 ;
QDONE KILL DA,DIE,DR,A,LD,LT,B,PS,PURGEDAYS,PDT,LDT,DIDEL
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
