Routine: BLRALDR

BLRALDR ;DAOU/ALA-Lab Review Delinquent Report

 ;;5.2T9;LR;**1013,1015,1018**;Nov 17, 2004

 ;;5.2;LR;**1013,1015**;Nov 18, 2002

 ;**Program Description**

 ;  This routine builds a ListMan screen of all delinquent lab

 ;  results based upon a supervisor's subordinates and the

 ;  supervisor's normal and abnormal review days defined

CSUP ;  Check for all subordinates of a Clinician Supervisor

 K ^TMP("BLRADELQ",$J)

 ;  Get the Normal and Abnormal review days

 S BLRANRN=$$GET1^DIQ(9009027.1,DUZ,.04,"E")

 S BLRAARN=$$GET1^DIQ(9009027.1,DUZ,.05,"E")

 S BLRACRN=$$GET1^DIQ(9009027.1,DUZ,.06,"E")

 S BLRADUZ=""

 F  S BLRADUZ=$O(^BLRALAB(9009027.1,"C",DUZ,BLRADUZ)) Q:BLRADUZ=""  D FND

 D EN^BLRAL3

 K BLRA0,BLRAAB,BLRAARN,BLRACCN,BLRADATA,BLRADLT,BLRADTT,BLRADUZ,BLRADT

 K BLRANRN,BLRAOPH,BLRAP,BLRAPD,BLRAPFL,BLRAPIEN,BLRAPNM,BLRAS,BLRACRT

 K BLRASTAT,BLRIDT,BLRSS,BLRVD,^TMP("BLRADELQ",$J),BLRACRN,BLRADAYS

 K BLRALINE,BLRALVAR,BLRAOPNM,BLRAPHY,BLRARPHY,BLRARPNM,BLRASTA,BLRAVD

 K BLRAVT,DATE

FND ;  Find results

 S BLRAS=""

 F  S BLRAS=$O(^LR("BLRA",BLRADUZ,BLRAS)) Q:BLRAS=2!(BLRAS="")  D

 . S BLRVD=""

 . F  S BLRVD=$O(^LR("BLRA",BLRADUZ,BLRAS,BLRVD)) Q:BLRVD=""  D

 .. S BLRAP=""

 .. F  S BLRAP=$O(^LR("BLRA",BLRADUZ,BLRAS,BLRVD,BLRAP)) Q:BLRAP=""  D

 ... ;S BLRIDT=$P(BLRVD,"-",2),BLRSS=$G(^LR("BLRA",BLRADUZ,BLRAS,BLRVD,BLRAP))

 ... ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 ... ;ADDED BLRSS AS SUBSCRIPT

 ... S BLRSS=""

 ... F  S BLRSS=$O(^LR("BLRA",BLRADUZ,BLRAS,BLRVD,BLRAP,BLRSS)) Q:BLRSS=""  D

 .... S BLRIDT=$P(BLRVD,"-",2)

 .... ;----- END IHS MODIFICATIONS

 .... S BLRA0=$G(^LR(BLRAP,BLRSS,BLRIDT,0))

 .... S BLRADATA=$G(^LR(BLRAP,BLRSS,BLRIDT,9009027))

 .... Q:$G(BLRADATA)=""  ;IF NOT THERE ITS BEEN DELETED

 .... ;

 .... S BLRAAB=$P(BLRADATA,U,6),BLRAPD=$P(BLRADATA,U,7),BLRACRT=+$P(BLRADATA,U,8)

 .... ;

 .... ;  If any pending results, don't put on the delinquent report

 .... I BLRAPD Q

 .... S BLRARPHY=$P(BLRADATA,U,2)

 .... S BLRARPNM=$P($G(^VA(200,BLRARPHY,0)),U)

 .... ;

 .... S BLRADTT=$P(BLRA0,U,1),BLRAOPH=$P(BLRA0,U,$S(BLRSS="MI":7,1:10))

 .... S BLRACCN=$P(BLRA0,U,6),BLRAOPNM=$P($G(^VA(200,BLRAOPH,0)),U)

 .... S BLRAPFL=$P($G(^LR(BLRAP,0)),U,2),BLRAPIEN=$P($G(^(0)),U,3)

 .... S BLRAPNM=$$GET1^DIQ(BLRAPFL,BLRAPIEN,.01,"E")

 .... ;

 .... S BLRASTAT=$S(BLRACRT'=0:"CRIT",BLRAAB'=0:"ABN",1:"NOR")

 .... S BLRASTA=$S(BLRASTAT="CRIT":"AAC",1:BLRASTAT)

 .... ;

 .... S BLRADLT=$$FMADD^XLFDT(BLRADTT\1,$S(BLRASTAT="ABN":BLRAARN,BLRASTAT="CRIT":BLRACRN,1:BLRANRN))

 .... I DT'>BLRADLT Q

 .... ;

 .... S BLRADAYS=$$FMDIFF^XLFDT(DT,BLRADLT,1)

 .... ;

 .... S BLRAVT=$P(BLRADTT,".",2),BLRAVT=BLRAVT_$E("000000",$L(BLRAVT),7)

 .... S BLRAVD=$P(BLRADTT,".",1)_"."_BLRAVT

 .... ;S ^TMP("BLRADELQ",$J,BLRARPNM,BLRASTA,BLRAVD,BLRAP)=BLRACCN_U_BLRAPNM_U_(BLRADTT\1)_U_BLRAOPNM_U_BLRASTAT_U_BLRADAYS

 .... ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 .... S ^TMP("BLRADELQ",$J,BLRARPNM,BLRASTA,BLRAVD,BLRAP,BLRSS)=BLRACCN_U_BLRAPNM_U_(BLRADTT\1)_U_BLRAOPNM_U_BLRASTAT_U_BLRADAYS

 .... ;----- END IHS MODIFICATIONS

 .... ;S ^TMP("BLRADELQ",$J,BLRARPNM,BLRASTA,BLRAVD,BLRAP,"ZNODE")=BLRAP_U_BLRSS_U_BLRIDT

BLRALDR   ;DAOU/ALA-Lab Review Delinquent Report

 +1       ;;5.2T9;LR;**1013,1015,1018**;Nov 17, 2004

 +2       ;;5.2;LR;**1013,1015**;Nov 18, 2002

 +3       ;

 +4       ;**Program Description**

 +5       ;  This routine builds a ListMan screen of all delinquent lab

 +6       ;  results based upon a supervisor's subordinates and the

 +7       ;  supervisor's normal and abnormal review days defined

 +8       ;

CSUP      ;  Check for all subordinates of a Clinician Supervisor

 +1        KILL ^TMP("BLRADELQ",$JOB)

 +2       ;

 +3       ;  Get the Normal and Abnormal review days

 +4        SET BLRANRN=$$GET1^DIQ(9009027.1,DUZ,.04,"E")

 +5        SET BLRAARN=$$GET1^DIQ(9009027.1,DUZ,.05,"E")

 +6        SET BLRACRN=$$GET1^DIQ(9009027.1,DUZ,.06,"E")

 +7       ;

 +8        SET BLRADUZ=""

 +9        FOR

               SET BLRADUZ=$ORDER(^BLRALAB(9009027.1,"C",DUZ,BLRADUZ))

               IF BLRADUZ=""

                   QUIT

               DO FND

 +10      ;

 +11       DO EN^BLRAL3

 +12      ;

 +13       KILL BLRA0,BLRAAB,BLRAARN,BLRACCN,BLRADATA,BLRADLT,BLRADTT,BLRADUZ,BLRADT

 +14       KILL BLRANRN,BLRAOPH,BLRAP,BLRAPD,BLRAPFL,BLRAPIEN,BLRAPNM,BLRAS,BLRACRT

 +15       KILL BLRASTAT,BLRIDT,BLRSS,BLRVD,^TMP("BLRADELQ",$JOB),BLRACRN,BLRADAYS

 +16       KILL BLRALINE,BLRALVAR,BLRAOPNM,BLRAPHY,BLRARPHY,BLRARPNM,BLRASTA,BLRAVD

 +17       KILL BLRAVT,DATE

 +18       QUIT

 +19      ;

FND       ;  Find results

 +1        SET BLRAS=""

 +2        FOR

               SET BLRAS=$ORDER(^LR("BLRA",BLRADUZ,BLRAS))

               IF BLRAS=2!(BLRAS="")

                   QUIT

               Begin DoDot:1

 +3                SET BLRVD=""

 +4                FOR

                       SET BLRVD=$ORDER(^LR("BLRA",BLRADUZ,BLRAS,BLRVD))

                       IF BLRVD=""

                           QUIT

                       Begin DoDot:2

 +5                        SET BLRAP=""

 +6                        FOR

                               SET BLRAP=$ORDER(^LR("BLRA",BLRADUZ,BLRAS,BLRVD,BLRAP))

                               IF BLRAP=""

                                   QUIT

                               Begin DoDot:3

 +7       ;S BLRIDT=$P(BLRVD,"-",2),BLRSS=$G(^LR("BLRA",BLRADUZ,BLRAS,BLRVD,BLRAP))

 +8       ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +9       ;ADDED BLRSS AS SUBSCRIPT

 +10                               SET BLRSS=""

 +11                               FOR

                                       SET BLRSS=$ORDER(^LR("BLRA",BLRADUZ,BLRAS,BLRVD,BLRAP,BLRSS))

                                       IF BLRSS=""

                                           QUIT

                                       Begin DoDot:4

 +12                                       SET BLRIDT=$PIECE(BLRVD,"-",2)

 +13      ;----- END IHS MODIFICATIONS

 +14                                       SET BLRA0=$GET(^LR(BLRAP,BLRSS,BLRIDT,0))

 +15                                       SET BLRADATA=$GET(^LR(BLRAP,BLRSS,BLRIDT,9009027))

 +16      ;IF NOT THERE ITS BEEN DELETED

                                           IF $GET(BLRADATA)=""

                                               QUIT

 +17      ;

 +18                                       SET BLRAAB=$PIECE(BLRADATA,U,6)

                                           SET BLRAPD=$PIECE(BLRADATA,U,7)

                                           SET BLRACRT=+$PIECE(BLRADATA,U,8)

 +19      ;

 +20      ;  If any pending results, don't put on the delinquent report

 +21                                       IF BLRAPD

                                               QUIT

 +22                                       SET BLRARPHY=$PIECE(BLRADATA,U,2)

 +23                                       SET BLRARPNM=$PIECE($GET(^VA(200,BLRARPHY,0)),U)

 +24      ;

 +25                                       SET BLRADTT=$PIECE(BLRA0,U,1)

                                           SET BLRAOPH=$PIECE(BLRA0,U,$SELECT(BLRSS="MI":7,1:10))

 +26                                       SET BLRACCN=$PIECE(BLRA0,U,6)

                                           SET BLRAOPNM=$PIECE($GET(^VA(200,BLRAOPH,0)),U)

 +27                                       SET BLRAPFL=$PIECE($GET(^LR(BLRAP,0)),U,2)

                                           SET BLRAPIEN=$PIECE($GET(^(0)),U,3)

 +28                                       SET BLRAPNM=$$GET1^DIQ(BLRAPFL,BLRAPIEN,.01,"E")

 +29      ;

 +30                                       SET BLRASTAT=$SELECT(BLRACRT'=0:"CRIT",BLRAAB'=0:"ABN",1:"NOR")

 +31                                       SET BLRASTA=$SELECT(BLRASTAT="CRIT":"AAC",1:BLRASTAT)

 +32      ;

 +33                                       SET BLRADLT=$$FMADD^XLFDT(BLRADTT\1,$SELECT(BLRASTAT="ABN":BLRAARN,BLRASTAT="CRIT":BLRACRN,1:BLRANRN))

 +34                                       IF DT'>BLRADLT

                                               QUIT

 +35      ;

 +36                                       SET BLRADAYS=$$FMDIFF^XLFDT(DT,BLRADLT,1)

 +37      ;

 +38                                       SET BLRAVT=$PIECE(BLRADTT,".",2)

                                           SET BLRAVT=BLRAVT_$EXTRACT("000000",$LENGTH(BLRAVT),7)

 +39                                       SET BLRAVD=$PIECE(BLRADTT,".",1)_"."_BLRAVT

 +40      ;S ^TMP("BLRADELQ",$J,BLRARPNM,BLRASTA,BLRAVD,BLRAP)=BLRACCN_U_BLRAPNM_U_(BLRADTT\1)_U_BLRAOPNM_U_BLRASTAT_U_BLRADAYS

 +41      ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +42                                       SET ^TMP("BLRADELQ",$JOB,BLRARPNM,BLRASTA,BLRAVD,BLRAP,BLRSS)=BLRACCN_U_BLRAPNM_U_(BLRADTT\1)_U_BLRAOPNM_U_BLRASTAT_U_BLRADAYS

 +43      ;----- END IHS MODIFICATIONS

 +44      ;S ^TMP("BLRADELQ",$J,BLRARPNM,BLRASTA,BLRAVD,BLRAP,"ZNODE")=BLRAP_U_BLRSS_U_BLRIDT

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +45       QUIT

BLRALDR.m