Routine: BLRALBL

BLRALBL ;DAOU/ALA-Build list data for ListMan

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

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

 ;**Program Description**

 ;  Go through the cross-reference and build an

 ;  array for ListMan

 ;  Input Parameter

 ;    DUZ =  User IEN

SELF ;  Get result for self

 K ^TMP("BLRA",$J) S BLRAHDR="*** MAIN SCREEN ***"

 S BLRADUZ=DUZ D FND

TSUR ;  Check for temporary surrogates

 ;  A temporary surrogate had a date range limit

 ;  Parameters

 ;    BSTDT = Start Date

 ;    BENDT = End Date

 S BLRADUZ=""

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

 . S BSTDT=$P($G(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,2)

 . S BENDT=$P($G(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,3)

 . I BENDT=""!(BSTDT="") Q

 . I DT'<BSTDT&(DT'>BENDT) D FND

PSUR ;EP - Left in for Chinle site which may still have perm surrogates

 ;  Change for issue #12 ejn - 3/22/02

 ;  Check for permanent surrogates

 ;K ^TMP("BLRA",$J) S BLRAHDR="***OTHER PROVIDERS***"

 S BLRADUZ=""

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

 . S BSTDT=$P($G(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,2)

 . S BENDT=$P($G(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,3)

 . I BSTDT=""&(BENDT="") D FND

FND ;  Find results

 ;  Parameters

 ;    BLRADUZ = Provider IEN

 ;    BLRAS = Result Status

 ;    BLRVD = Negative Reverse Date

 ;    BLRAP = Lab Patient IEN

 ;    BLRIDT = Reverse Date

 ;    BLRSS = Lab Accession Subscript

 ;    BLRADATA = Lab ES Data

 ;    BLRAAB = Number of abnormal results

 ;    BLRAPD = Number of pending results

 ;    BLRADTT = Lab Accession Collection Date/time

 ;    BLRAOPH = Ordering Provider

 ;    BLRARPHY = Responsible Provider

 ;    BLRACCN = Accession Number

 ;    BLRAPFL = Lab Patient File Number

 ;    BLRAPIEN = Patient IEN

 ;    BLRAPNM = Patient Name

 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 BLRIDT=$P(BLRVD,"-",2)

 .. 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

 ...S BLRSS=""

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

 ....;W !,BLRVD,"  ",BLRAP,"  ",BLRSS

 ....;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:BLRADATA=""  ;IHS/ITSC/TPF IF NO DATA DON'T PROCESS 07/23/2002

 .... ;W !,BLRVD,"  ",BLRAP,"  ",BLRSS

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

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

 .... S BLRRCT=+$P(BLRADATA,U,9)

 .... ;

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

 .... S BLRACCN=$P(BLRA0,U,6)

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

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

 .... ;

 .... S BLRASTAT=$S(BLRCRTL'=0:"CRIT",BLRAAB'=0:"ABN",BLRRCT'=0:"N/A",1:"NOR"),BLRASTA=BLRASTAT

 .... I BLRASTAT="CRIT" S BLRASTAT="AA"

 .... ;

 .... I $G(BLRASRT)="" D

 ..... ;S ^TMP("BLRA",$J,BLRASTAT,BLRVD,BLRAP)=BLRACCN_U_BLRAPNM_U_BLRADTT_U_BLRARPHY_U_BLRASTA_U_$S(BLRAPD=0:"YES",1:"PEND")

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

 ..... S ^TMP("BLRA",$J,BLRASTAT,BLRVD,BLRAP,BLRSS)=BLRACCN_U_BLRAPNM_U_BLRADTT_U_BLRARPHY_U_BLRASTA_U_$S(BLRAPD=0:"YES",1:"PEND")

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

 ..... Q:$G(BLRACCN)=""  ;IHS/ITSC/TPF 03/26/02 TEMPORARY FIX PER CNR (CARL RANDALL MITRTEK)

 ..... S ^TMP("BLRA",$J,"ZNODE",BLRACCN)=BLRAP_U_BLRSS_U_BLRIDT

 ....;

 .... I $G(BLRASRT)="P" D

 ..... S ^TMP("BLRA",$J,BLRAPNM,BLRASTAT,BLRVD,BLRSS)=BLRACCN_U_BLRAPNM_U_BLRADTT_U_BLRARPHY_U_BLRASTA_U_$S(BLRAPD=0:"YES",1:"PEND")

 ..... S ^TMP("BLRA",$J,"ZNODE",BLRACCN)=BLRAP_U_BLRSS_U_BLRIDT

CSUP ;EP

 ;  Check for all subordinates of a Clinician Supervisor

 K ^TMP("BLRA",$J) S BLRAHDR="***SUBORDINATE PROVIDERS***"

 S BLRADUZ=""

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

PATS ;EP

 ; Patient sort

 S BLRASRT="P"

 D SELF

BLRALBL   ;DAOU/ALA-Build list data for ListMan

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

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

 +3       ;

 +4       ;**Program Description**

 +5       ;  Go through the cross-reference and build an

 +6       ;  array for ListMan

 +7       ;

 +8       ;  Input Parameter

 +9       ;    DUZ =  User IEN

 +10      ;

SELF      ;  Get result for self

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

           SET BLRAHDR="*** MAIN SCREEN ***"

 +2        SET BLRADUZ=DUZ

           DO FND

 +3       ;

TSUR      ;  Check for temporary surrogates

 +1       ;  A temporary surrogate had a date range limit

 +2       ;

 +3       ;  Parameters

 +4       ;    BSTDT = Start Date

 +5       ;    BENDT = End Date

 +6       ;

 +7        SET BLRADUZ=""

 +8        FOR

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

               IF BLRADUZ=""

                   QUIT

               Begin DoDot:1

 +9                SET BSTDT=$PIECE($GET(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,2)

 +10               SET BENDT=$PIECE($GET(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,3)

 +11               IF BENDT=""!(BSTDT="")

                       QUIT

 +12               IF DT'<BSTDT&(DT'>BENDT)

                       DO FND

               End DoDot:1

 +13      ;

PSUR      ;EP - Left in for Chinle site which may still have perm surrogates

 +1       ;  Change for issue #12 ejn - 3/22/02

 +2       ;  Check for permanent surrogates

 +3       ;K ^TMP("BLRA",$J) S BLRAHDR="***OTHER PROVIDERS***"

 +4        SET BLRADUZ=""

 +5        FOR

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

               IF BLRADUZ=""

                   QUIT

               Begin DoDot:1

 +6                SET BSTDT=$PIECE($GET(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,2)

 +7                SET BENDT=$PIECE($GET(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,3)

 +8                IF BSTDT=""&(BENDT="")

                       DO FND

               End DoDot:1

 +9        QUIT

 +10      ;

FND       ;  Find results

 +1       ;

 +2       ;  Parameters

 +3       ;    BLRADUZ = Provider IEN

 +4       ;    BLRAS = Result Status

 +5       ;    BLRVD = Negative Reverse Date

 +6       ;    BLRAP = Lab Patient IEN

 +7       ;    BLRIDT = Reverse Date

 +8       ;    BLRSS = Lab Accession Subscript

 +9       ;    BLRADATA = Lab ES Data

 +10      ;    BLRAAB = Number of abnormal results

 +11      ;    BLRAPD = Number of pending results

 +12      ;    BLRADTT = Lab Accession Collection Date/time

 +13      ;    BLRAOPH = Ordering Provider

 +14      ;    BLRARPHY = Responsible Provider

 +15      ;    BLRACCN = Accession Number

 +16      ;    BLRAPFL = Lab Patient File Number

 +17      ;    BLRAPIEN = Patient IEN

 +18      ;    BLRAPNM = Patient Name

 +19      ;

 +20       SET BLRAS=""

 +21       FOR

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

               IF BLRAS=2!(BLRAS="")

                   QUIT

               Begin DoDot:1

 +22               SET BLRVD=""

 +23               FOR

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

                       IF BLRVD=""

                           QUIT

                       Begin DoDot:2

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

 +25                       SET BLRAP=""

 +26                       FOR

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

                               IF BLRAP=""

                                   QUIT

                               Begin DoDot:3

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

 +28      ;----- BEGIN IHS MODIFICATIONS LR*5.2

 +29                               SET BLRSS=""

 +30                               FOR

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

                                       IF BLRSS=""

                                           QUIT

                                       Begin DoDot:4

 +31      ;W !,BLRVD,"  ",BLRAP,"  ",BLRSS

 +32      ;S BLRIDT=$P(BLRVD,"-",2)

 +33      ;----- END IHS MODIFICATIONS

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

 +35      ;

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

 +37      ;IHS/ITSC/TPF IF NO DATA DON'T PROCESS 07/23/2002

                                           IF BLRADATA=""

                                               QUIT

 +38      ;W !,BLRVD,"  ",BLRAP,"  ",BLRSS

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

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

 +40                                       SET BLRCRTL=+$PIECE(BLRADATA,U,8)

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

 +41                                       SET BLRRCT=+$PIECE(BLRADATA,U,9)

 +42      ;

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

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

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

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

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

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

 +47      ;

 +48                                       SET BLRASTAT=$SELECT(BLRCRTL'=0:"CRIT",BLRAAB'=0:"ABN",BLRRCT'=0:"N/A",1:"NOR")

                                           SET BLRASTA=BLRASTAT

 +49                                       IF BLRASTAT="CRIT"

                                               SET BLRASTAT="AA"

 +50      ;

 +51                                       IF $GET(BLRASRT)=""

                                               Begin DoDot:5

 +52      ;S ^TMP("BLRA",$J,BLRASTAT,BLRVD,BLRAP)=BLRACCN_U_BLRAPNM_U_BLRADTT_U_BLRARPHY_U_BLRASTA_U_$S(BLRAPD=0:"YES",1:"PEND")

 +53      ;----- BEGIN IHS MODIFICATIONS LR*5.2

 +54                                               SET ^TMP("BLRA",$JOB,BLRASTAT,BLRVD,BLRAP,BLRSS)=BLRACCN_U_BLRAPNM_U_BLRADTT_U_BLRARPHY_U_BLRASTA_U_$SELECT(BLRAPD=0:"YES",1:"PEND")

 +55      ;----- END IHS MODIFICATIONS

 +56      ;IHS/ITSC/TPF 03/26/02 TEMPORARY FIX PER CNR (CARL RANDALL MITRTEK)

                                                   IF $GET(BLRACCN)=""

                                                       QUIT

 +57                                               SET ^TMP("BLRA",$JOB,"ZNODE",BLRACCN)=BLRAP_U_BLRSS_U_BLRIDT

                                               End DoDot:5

 +58      ;

 +59                                       IF $GET(BLRASRT)="P"

                                               Begin DoDot:5

 +60                                               SET ^TMP("BLRA",$JOB,BLRAPNM,BLRASTAT,BLRVD,BLRSS)=BLRACCN_U_BLRAPNM_U_BLRADTT_U_BLRARPHY_U_BLRASTA_U_$SELECT(BLRAPD=0:"YES",1:"PEND")

 +61                                               SET ^TMP("BLRA",$JOB,"ZNODE",BLRACCN)=BLRAP_U_BLRSS_U_BLRIDT

                                               End DoDot:5

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +62       QUIT

 +63      ;

CSUP      ;EP

 +1       ;  Check for all subordinates of a Clinician Supervisor

 +2        KILL ^TMP("BLRA",$JOB)

           SET BLRAHDR="***SUBORDINATE PROVIDERS***"

 +3        SET BLRADUZ=""

 +4        FOR

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

               IF BLRADUZ=""

                   QUIT

               DO FND

 +5        QUIT

 +6       ;

PATS      ;EP

 +1       ; Patient sort

 +2        SET BLRASRT="P"

 +3        DO SELF

 +4        QUIT

BLRALBL.m