LRCAPDAR ;DALOI/FHS/RBN - LAB DSS RESULTS EXTRACT (LAR) ;6/5/18 15:59
;;5.2;LAB SERVICE;**143,169,258,307,326,386,385,394,399,420,455,510**;Sep 27, 1994;Build 2
;
; Call with Start Date (LRSDT) End Date (LREDT) FileMan format
; Calling routine should have already purged ^LAR(64.036)
EN S:$D(ZTQUEUED) ZTREQ="@"
I $S($G(LRSDT)'?7N:1,$G(LREDT)'?7N:1,1:0) Q
L +^LAR(64.036):2 G:'$T END
N DIR,DIC,DIE,X,I,LR3,LRAA,LRAD,LRAN,LRC,LRSPDT,LRSPTM,UID,Y,DLAYGO,NEXTMO,RERUN ;420
N LRDFN,LRDN,LRY,LRNLT,LRLOINC,ARRAY,LRP8
S DLAYGO=64
I LRSDT>LREDT S X=LRSDT,LRSDT=LREDT,LREDT=X
S LRX1=9999999-(LRSDT_.0001),LRX2=9999999-(LREDT_.235959)
S:'$D(^LAR(64.036,0))#2 ^LAR(64.036,0)="LAB DSS LAR EXTRACT^64.036^2"
LR ;
K ARRAY S ARRAY("ALL")="" D LOINC^ECXUTL6(.ARRAY) ;Build ^TMP($J,"ECXUTL6")
S NEXTMO=$E($$FMADD^XLFDT(LREDT,1),1,5) ;420 Get next month, year and month
S RERUN=$D(^XTMP("LRECX",NEXTMO)) ;420 Need to know if we're re-running an extract.
D MISSED ;420 Look at skipped entries from previous month's extract
S LRDFN=0 F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 I $P($G(^LR(LRDFN,0)),U,2)=2 S LRN=^(0) D
. S DFN=$P(LRN,U,3),LRDPF=$P(LRN,U,2)
. S LRIDT=LRX2
. F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1!(LRIDT>LRX1) I $D(^(LRIDT,0)) S LRVSPEC=$P(^(0),U,5),LRN0=^(0) D
. . I '$P(^LR(LRDFN,"CH",LRIDT,0),U,3) D SAVE Q ;420 If accessioned and no result, put on list for next month.
. . I RERUN I +$G(^XTMP("LRECX",NEXTMO,LRDFN,LRIDT))=1 Q ;420 Don't consider this record as it's already been counted in the following month's extract.
. . I RERUN I $G(ECXTL)'="LAR" K ^XTMP("LRECX",NEXTMO,LRDFN,LRIDT) ;420 If re-running the extract and it's not the untranslatable report then remove entry from next month's list as we now have a result
. . S LRDN=0 F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<1 D
. . . S LRY=$$TSTRES^LRRPU(LRDFN,"CH",LRIDT,LRDN,"",1)
. . . S LRP8=$P(LRY,U,8)
. . . S LRNLT=$P($P(LRP8,"!",2),";"),LRLOINC=$P($P(LRP8,"!",3),";")
. . . Q:'(+LRLOINC)
. . . I +$G(^TMP($J,"ECXUTL6",LRLOINC))>0 D SET
. . I $O(LRVV(0)) D FILE
WRAP K DA,DR,DIC,DIE,DD,DO
S (X,DINUM)=1
S DIC="^LAR(64.036,",DIC(0)="LNM" D FILE^DICN S DA=+Y
G:Y<1 END
S DR="9///"_DT,DR(2,64.369)=".01///"_DT_";1///"_LRSDT_";2///"_LREDT_";3///"_$$NOW^LRAFUNC1_";4////"_$G(DUZ)
S DIE=DIC D ^DIE G END
Q
SET S LRVV(+$P(^TMP($J,"ECXUTL6",LRLOINC),U,2),LRDN)=$TR($E($P(LRY,U),1,35),";","-")_U_$P(LRY,U,2)_U_LRNLT_U_LRLOINC ;455,510 Allow up to 35 characters in the result
Q
END L -^LAR(64.036)
K D,D0,D1,DA,DFN,DI,DIC,DIE,DR,I,II,LRDA,LRDPF,LRIDT,LRN,LRN0
K LRNOW,LRSB,LRSP,LRTS,LRVR,LRVSPEC,LRVV,LRX1,LRX2,X,DLAYGO
K LRDFN,D2,LRSP,LRTS,DINUM,^TMP($J,"ECXUTL6") Q
FILE K DR,DA,DIC,DIR,LRPROV
D UID
S LRN0T1=$P(LRN0,U),LRN0T2=$P(LRN0,U,3),LRPROV=$P(LRN0,U,10)
S $P(LRN0,U)=$S(LRN0T2<LRN0T1:LRN0T2,1:LRN0T1)
S X=$P(^LAR(64.036,0),U,3) S:X<2 X=2 F X=X:1 Q:'$D(^LAR(64.036,X))
S DA=X,DIC="^LAR(64.036,",DINUM=X,DIC(0)="LNMF"
S LRN0T1=$E($P($P(LRN0,U),".",2),1,4) S:'LRN0T1 LRN0T1=0 I LRN0T1,$E(LRN0T1,3,4)>59 S LRN0T1=$E(LRN0T1,1,2)_"59"
S LRN0T2=$E($P($P(LRN0,U,3),".",2),1,4) S:'LRN0T2 LRN0T2=0
S DIC("DR")="1///"_LRDPF_";2///"_DFN_";3///"_$P($P(LRN0,U),".")_";4///"_LRN0T1_";5///"_$P($P(LRN0,U,3),".")_";6///"_LRN0T2_";7///`"_LRVSPEC_";12///`"_LRPROV
K DD,DO D FILE^DICN K DA S LRDA=Y Q:LRDA<1
S $P(^LAR(64.036,+LRDA,0),U,9)=LRSPDT,$P(^(0),U,10)=LRSPTM
F2 S DA(1)=+LRDA
S DIC=DIC_DA(1)_",1,"
S DIC(0)="L",DIC("P")=$P(^DD(64.036,8,0),"^",2)
F LRTS=0:0 S LRTS=$O(LRVV(LRTS)) Q:LRTS<1 D
.S LRDN=0 F S LRDN=$O(LRVV(LRTS,LRDN)) Q:LRDN<1 D DR1
K LRVV,LRN0T1,LRN0T2
Q
DR1 K DR,DIR,DIE S DA=+LRDA
S DIC("DR")=".01///"_LRTS_";1///"_$P(LRVV(LRTS,LRDN),U)_";2///"_$P(LRVV(LRTS,LRDN),U,2)_";3///"_$P(LRVV(LRTS,LRDN),U,3)_";4///"_$P(LRVV(LRTS,LRDN),U,4)
S X=LRTS
K D0 D FILE^DICN
Q
FIX S X=$P(^LAR(64.036,0),U,1,2) K ^LAR(64.036) S ^LAR(64.036,0)=X Q
UID ;
S LRN0T2=$P(LRN0,U,3)
S LRSPDT=$P($P(LRN0,U),"."),LRSPTM=$E($P($P(LRN0,U),".",2),1,4)
D
. I 'LRSPTM S LRSPTM=1 Q
. I LRSPTM,$E(LRSPTM,3,4)>59 S LRSPTM=$E(LRSPTM,1,2)_"59"
S LRN0T1=LRSPDT_"."_LRSPTM,$P(LRN0,U)=LRN0T1
S UID=$P($G(^LR(LRDFN,"CH",LRIDT,"ORU")),U) Q:'$L(UID)
S LRC=$Q(^LRO(68,"C",UID)) Q:$QS(LRC,3)'=UID
S LRAA=$QS(LRC,4),LRAD=$QS(LRC,5),LRAN=$QS(LRC,6)
D
. N LR3,LRODT,LROODT,LRSN
. Q:'$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LR3=^(0)
. S LRODT=$P(LR3,U,4),LRSN=$P(LR3,U,5)
. S LROODT=$P($G(^LRO(69,LRODT,1,LRSN,0)),U,5)
. I $G(LROODT) S $P(LRN0,U)=LROODT
Q
;
SAVE ;added in patch 420, save records for next month's review if no result
;In this section we're saving any records that don't have a value in
;the date report completed field in the CHEM multiple of the LAB DATA
;file. We don't save records if the user is running the lab
;untranslatable report. If we're re-running the extract for the month
;then we don't count the record if it's been counted in a subsequent
;month's extract. Finally, we set the record into the XTMP global for
;later retrieval. It will be deleted one year from being stored.
I $G(ECXTL)="LAR" Q ;Don't add to the list if running untranslatable report.
I RERUN I +$G(^XTMP("LRECX",NEXTMO,LRDFN,LRIDT)) Q ;Don't update an entry on the list if we've already counted it.
I '$D(^XTMP("LRECX",NEXTMO,0)) S ^XTMP("LRECX",NEXTMO,0)=$$FMADD^XLFDT($$DT^XLFDT,365)_"^"_$$DT^XLFDT_"^"_"Accessioned tests without results"
S ^XTMP("LRECX",NEXTMO,LRDFN,LRIDT)="" ;save specific record
Q
;
MISSED ;added in patch 420, process any records missed in previous month's extract
;In this section we will look at the lab tests from the previous month
;that didn't have a result when the extract was run. If they now have
;a result, they'll be counted if they match the LOINC criteria. We
;only check records in the month after they were identified as no lab
;test that we report on should take more than 30 days to result. When
;we count a test that we previously skipped, the entry in the XTMP
;global is set equal to 1 to denote that we've processed this record
;and it shouldn't be counted in future extracts or in reruns of
;an extract month.
N CURMO,LRDFN,LRN,LRDN,LRIDT,LRVSPEC,LRN0,LRY,LRP8,LRNLT,LRLOINC,LRVV
S CURMO=$E(LRSDT,1,5) ;Year and month we're extracting
I '$D(^XTMP("LRECX",CURMO,0)) Q ;No records to review
S LRDFN=0 F S LRDFN=$O(^XTMP("LRECX",CURMO,LRDFN)) Q:LRDFN<1 I $P($G(^LR(LRDFN,0)),U,2)=2 S LRN=^(0) D
. S DFN=$P(LRN,U,3),LRDPF=$P(LRN,U,2)
. S LRIDT=0
. F S LRIDT=$O(^XTMP("LRECX",CURMO,LRDFN,LRIDT)) Q:LRIDT<1 I $D(^LR(LRDFN,"CH",LRIDT,0)),$P(^(0),U,3) S LRVSPEC=$P(^(0),U,5),LRN0=^(0) D
. . S LRDN=0 F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<1 D
. . . S LRY=$$TSTRES^LRRPU(LRDFN,"CH",LRIDT,LRDN,"",1)
. . . S LRP8=$P(LRY,U,8)
. . . S LRNLT=$P($P(LRP8,"!",2),";"),LRLOINC=$P($P(LRP8,"!",3),";")
. . . Q:'(+LRLOINC)
. . . I +$G(^TMP($J,"ECXUTL6",LRLOINC))>0 D SET
. . I $O(LRVV(0)) D FILE I $G(ECXTL)'="LAR" S ^XTMP("LRECX",CURMO,LRDFN,LRIDT)=1 ;Mark it as counted in this month's extract
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPDAR 7117 printed Oct 16, 2024@18:13:36 Page 2
LRCAPDAR ;DALOI/FHS/RBN - LAB DSS RESULTS EXTRACT (LAR) ;6/5/18 15:59
+1 ;;5.2;LAB SERVICE;**143,169,258,307,326,386,385,394,399,420,455,510**;Sep 27, 1994;Build 2
+2 ;
+3 ; Call with Start Date (LRSDT) End Date (LREDT) FileMan format
+4 ; Calling routine should have already purged ^LAR(64.036)
EN if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 IF $SELECT($GET(LRSDT)'?7N:1,$GET(LREDT)'?7N:1,1:0)
QUIT
+2 LOCK +^LAR(64.036):2
if '$TEST
GOTO END
+3 ;420
NEW DIR,DIC,DIE,X,I,LR3,LRAA,LRAD,LRAN,LRC,LRSPDT,LRSPTM,UID,Y,DLAYGO,NEXTMO,RERUN
+4 NEW LRDFN,LRDN,LRY,LRNLT,LRLOINC,ARRAY,LRP8
+5 SET DLAYGO=64
+6 IF LRSDT>LREDT
SET X=LRSDT
SET LRSDT=LREDT
SET LREDT=X
+7 SET LRX1=9999999-(LRSDT_.0001)
SET LRX2=9999999-(LREDT_.235959)
+8 if '$DATA(^LAR(64.036,0))#2
SET ^LAR(64.036,0)="LAB DSS LAR EXTRACT^64.036^2"
LR ;
+1 ;Build ^TMP($J,"ECXUTL6")
KILL ARRAY
SET ARRAY("ALL")=""
DO LOINC^ECXUTL6(.ARRAY)
+2 ;420 Get next month, year and month
SET NEXTMO=$EXTRACT($$FMADD^XLFDT(LREDT,1),1,5)
+3 ;420 Need to know if we're re-running an extract.
SET RERUN=$DATA(^XTMP("LRECX",NEXTMO))
+4 ;420 Look at skipped entries from previous month's extract
DO MISSED
+5 SET LRDFN=0
FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if LRDFN<1
QUIT
IF $PIECE($GET(^LR(LRDFN,0)),U,2)=2
SET LRN=^(0)
Begin DoDot:1
+6 SET DFN=$PIECE(LRN,U,3)
SET LRDPF=$PIECE(LRN,U,2)
+7 SET LRIDT=LRX2
+8 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
if LRIDT<1!(LRIDT>LRX1)
QUIT
IF $DATA(^(LRIDT,0))
SET LRVSPEC=$PIECE(^(0),U,5)
SET LRN0=^(0)
Begin DoDot:2
+9 ;420 If accessioned and no result, put on list for next month.
IF '$PIECE(^LR(LRDFN,"CH",LRIDT,0),U,3)
DO SAVE
QUIT
+10 ;420 Don't consider this record as it's already been counted in the following month's extract.
IF RERUN
IF +$GET(^XTMP("LRECX",NEXTMO,LRDFN,LRIDT))=1
QUIT
+11 ;420 If re-running the extract and it's not the untranslatable report then remove entry from next month's list as we now have a result
IF RERUN
IF $GET(ECXTL)'="LAR"
KILL ^XTMP("LRECX",NEXTMO,LRDFN,LRIDT)
+12 SET LRDN=0
FOR
SET LRDN=$ORDER(^LR(LRDFN,"CH",LRIDT,LRDN))
if LRDN<1
QUIT
Begin DoDot:3
+13 SET LRY=$$TSTRES^LRRPU(LRDFN,"CH",LRIDT,LRDN,"",1)
+14 SET LRP8=$PIECE(LRY,U,8)
+15 SET LRNLT=$PIECE($PIECE(LRP8,"!",2),";")
SET LRLOINC=$PIECE($PIECE(LRP8,"!",3),";")
+16 if '(+LRLOINC)
QUIT
+17 IF +$GET(^TMP($JOB,"ECXUTL6",LRLOINC))>0
DO SET
End DoDot:3
+18 IF $ORDER(LRVV(0))
DO FILE
End DoDot:2
End DoDot:1
WRAP KILL DA,DR,DIC,DIE,DD,DO
+1 SET (X,DINUM)=1
+2 SET DIC="^LAR(64.036,"
SET DIC(0)="LNM"
DO FILE^DICN
SET DA=+Y
+3 if Y<1
GOTO END
+4 SET DR="9///"_DT
SET DR(2,64.369)=".01///"_DT_";1///"_LRSDT_";2///"_LREDT_";3///"_$$NOW^LRAFUNC1_";4////"_$G(DUZ)
+5 SET DIE=DIC
DO ^DIE
GOTO END
+6 QUIT
SET ;455,510 Allow up to 35 characters in the result
SET LRVV(+$PIECE(^TMP($JOB,"ECXUTL6",LRLOINC),U,2),LRDN)=$TRANSLATE($EXTRACT($PIECE(LRY,U),1,35),";","-")_U_$PIECE(LRY,U,2)_U_LRNLT_U_LRLOINC
+1 QUIT
END LOCK -^LAR(64.036)
+1 KILL D,D0,D1,DA,DFN,DI,DIC,DIE,DR,I,II,LRDA,LRDPF,LRIDT,LRN,LRN0
+2 KILL LRNOW,LRSB,LRSP,LRTS,LRVR,LRVSPEC,LRVV,LRX1,LRX2,X,DLAYGO
+3 KILL LRDFN,D2,LRSP,LRTS,DINUM,^TMP($JOB,"ECXUTL6")
QUIT
FILE KILL DR,DA,DIC,DIR,LRPROV
+1 DO UID
+2 SET LRN0T1=$PIECE(LRN0,U)
SET LRN0T2=$PIECE(LRN0,U,3)
SET LRPROV=$PIECE(LRN0,U,10)
+3 SET $PIECE(LRN0,U)=$SELECT(LRN0T2<LRN0T1:LRN0T2,1:LRN0T1)
+4 SET X=$PIECE(^LAR(64.036,0),U,3)
if X<2
SET X=2
FOR X=X:1
if '$DATA(^LAR(64.036,X))
QUIT
+5 SET DA=X
SET DIC="^LAR(64.036,"
SET DINUM=X
SET DIC(0)="LNMF"
+6 SET LRN0T1=$EXTRACT($PIECE($PIECE(LRN0,U),".",2),1,4)
if 'LRN0T1
SET LRN0T1=0
IF LRN0T1
IF $EXTRACT(LRN0T1,3,4)>59
SET LRN0T1=$EXTRACT(LRN0T1,1,2)_"59"
+7 SET LRN0T2=$EXTRACT($PIECE($PIECE(LRN0,U,3),".",2),1,4)
if 'LRN0T2
SET LRN0T2=0
+8 SET DIC("DR")="1///"_LRDPF_";2///"_DFN_";3///"_$PIECE($PIECE(LRN0,U),".")_";4///"_LRN0T1_";5///"_$PIECE($PIECE(LRN0,U,3),".")_";6///"_LRN0T2_";7///`"_LRVSPEC_";12///`"_LRPROV
+9 KILL DD,DO
DO FILE^DICN
KILL DA
SET LRDA=Y
if LRDA<1
QUIT
+10 SET $PIECE(^LAR(64.036,+LRDA,0),U,9)=LRSPDT
SET $PIECE(^(0),U,10)=LRSPTM
F2 SET DA(1)=+LRDA
+1 SET DIC=DIC_DA(1)_",1,"
+2 SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(64.036,8,0),"^",2)
+3 FOR LRTS=0:0
SET LRTS=$ORDER(LRVV(LRTS))
if LRTS<1
QUIT
Begin DoDot:1
+4 SET LRDN=0
FOR
SET LRDN=$ORDER(LRVV(LRTS,LRDN))
if LRDN<1
QUIT
DO DR1
End DoDot:1
+5 KILL LRVV,LRN0T1,LRN0T2
+6 QUIT
DR1 KILL DR,DIR,DIE
SET DA=+LRDA
+1 SET DIC("DR")=".01///"_LRTS_";1///"_$PIECE(LRVV(LRTS,LRDN),U)_";2///"_$PIECE(LRVV(LRTS,LRDN),U,2)_";3///"_$PIECE(LRVV(LRTS,LRDN),U,3)_";4///"_$PIECE(LRVV(LRTS,LRDN),U,4)
+2 SET X=LRTS
+3 KILL D0
DO FILE^DICN
+4 QUIT
FIX SET X=$PIECE(^LAR(64.036,0),U,1,2)
KILL ^LAR(64.036)
SET ^LAR(64.036,0)=X
QUIT
UID ;
+1 SET LRN0T2=$PIECE(LRN0,U,3)
+2 SET LRSPDT=$PIECE($PIECE(LRN0,U),".")
SET LRSPTM=$EXTRACT($PIECE($PIECE(LRN0,U),".",2),1,4)
+3 Begin DoDot:1
+4 IF 'LRSPTM
SET LRSPTM=1
QUIT
+5 IF LRSPTM
IF $EXTRACT(LRSPTM,3,4)>59
SET LRSPTM=$EXTRACT(LRSPTM,1,2)_"59"
End DoDot:1
+6 SET LRN0T1=LRSPDT_"."_LRSPTM
SET $PIECE(LRN0,U)=LRN0T1
+7 SET UID=$PIECE($GET(^LR(LRDFN,"CH",LRIDT,"ORU")),U)
if '$LENGTH(UID)
QUIT
+8 SET LRC=$QUERY(^LRO(68,"C",UID))
if $QSUBSCRIPT(LRC,3)'=UID
QUIT
+9 SET LRAA=$QSUBSCRIPT(LRC,4)
SET LRAD=$QSUBSCRIPT(LRC,5)
SET LRAN=$QSUBSCRIPT(LRC,6)
+10 Begin DoDot:1
+11 NEW LR3,LRODT,LROODT,LRSN
+12 if '$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
SET LR3=^(0)
+13 SET LRODT=$PIECE(LR3,U,4)
SET LRSN=$PIECE(LR3,U,5)
+14 SET LROODT=$PIECE($GET(^LRO(69,LRODT,1,LRSN,0)),U,5)
+15 IF $GET(LROODT)
SET $PIECE(LRN0,U)=LROODT
End DoDot:1
+16 QUIT
+17 ;
SAVE ;added in patch 420, save records for next month's review if no result
+1 ;In this section we're saving any records that don't have a value in
+2 ;the date report completed field in the CHEM multiple of the LAB DATA
+3 ;file. We don't save records if the user is running the lab
+4 ;untranslatable report. If we're re-running the extract for the month
+5 ;then we don't count the record if it's been counted in a subsequent
+6 ;month's extract. Finally, we set the record into the XTMP global for
+7 ;later retrieval. It will be deleted one year from being stored.
+8 ;Don't add to the list if running untranslatable report.
IF $GET(ECXTL)="LAR"
QUIT
+9 ;Don't update an entry on the list if we've already counted it.
IF RERUN
IF +$GET(^XTMP("LRECX",NEXTMO,LRDFN,LRIDT))
QUIT
+10 IF '$DATA(^XTMP("LRECX",NEXTMO,0))
SET ^XTMP("LRECX",NEXTMO,0)=$$FMADD^XLFDT($$DT^XLFDT,365)_"^"_$$DT^XLFDT_"^"_"Accessioned tests without results"
+11 ;save specific record
SET ^XTMP("LRECX",NEXTMO,LRDFN,LRIDT)=""
+12 QUIT
+13 ;
MISSED ;added in patch 420, process any records missed in previous month's extract
+1 ;In this section we will look at the lab tests from the previous month
+2 ;that didn't have a result when the extract was run. If they now have
+3 ;a result, they'll be counted if they match the LOINC criteria. We
+4 ;only check records in the month after they were identified as no lab
+5 ;test that we report on should take more than 30 days to result. When
+6 ;we count a test that we previously skipped, the entry in the XTMP
+7 ;global is set equal to 1 to denote that we've processed this record
+8 ;and it shouldn't be counted in future extracts or in reruns of
+9 ;an extract month.
+10 NEW CURMO,LRDFN,LRN,LRDN,LRIDT,LRVSPEC,LRN0,LRY,LRP8,LRNLT,LRLOINC,LRVV
+11 ;Year and month we're extracting
SET CURMO=$EXTRACT(LRSDT,1,5)
+12 ;No records to review
IF '$DATA(^XTMP("LRECX",CURMO,0))
QUIT
+13 SET LRDFN=0
FOR
SET LRDFN=$ORDER(^XTMP("LRECX",CURMO,LRDFN))
if LRDFN<1
QUIT
IF $PIECE($GET(^LR(LRDFN,0)),U,2)=2
SET LRN=^(0)
Begin DoDot:1
+14 SET DFN=$PIECE(LRN,U,3)
SET LRDPF=$PIECE(LRN,U,2)
+15 SET LRIDT=0
+16 FOR
SET LRIDT=$ORDER(^XTMP("LRECX",CURMO,LRDFN,LRIDT))
if LRIDT<1
QUIT
IF $DATA(^LR(LRDFN,"CH",LRIDT,0))
IF $PIECE(^(0),U,3)
SET LRVSPEC=$PIECE(^(0),U,5)
SET LRN0=^(0)
Begin DoDot:2
+17 SET LRDN=0
FOR
SET LRDN=$ORDER(^LR(LRDFN,"CH",LRIDT,LRDN))
if LRDN<1
QUIT
Begin DoDot:3
+18 SET LRY=$$TSTRES^LRRPU(LRDFN,"CH",LRIDT,LRDN,"",1)
+19 SET LRP8=$PIECE(LRY,U,8)
+20 SET LRNLT=$PIECE($PIECE(LRP8,"!",2),";")
SET LRLOINC=$PIECE($PIECE(LRP8,"!",3),";")
+21 if '(+LRLOINC)
QUIT
+22 IF +$GET(^TMP($JOB,"ECXUTL6",LRLOINC))>0
DO SET
End DoDot:3
+23 ;Mark it as counted in this month's extract
IF $ORDER(LRVV(0))
DO FILE
IF $GET(ECXTL)'="LAR"
SET ^XTMP("LRECX",CURMO,LRDFN,LRIDT)=1
End DoDot:2
End DoDot:1
+24 QUIT
