- 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 Feb 18, 2025@23:38:44 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
