LRMLPRG.m

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 ---LRMLPRG   1498     printed  Feb 18, 2025@23:43:51                                                                                                                                                                                                     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