BLRALUT1.m

BLRALUT1 ;DAOU/ALA-Lab ES Utility 

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

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

 ;

 ;**Program Description**

 ;  This contains utilities for Lab Audit

 ;

SX ;EP

 ;  Set review cross-reference

 ;  ^LR("BLRA",BLRARPHY,BLRARFL,-LRIDT,LRDFN)

 ;     BLRARPHY  = Responsible Physician

 ;     BLRARFL = Review Status

 ;             0 = Not Reviewed 

 ;             1 = Reviewed, not signed 

 ;             2 = Reviewed, signed

 ;     LRIDT = Reverse Date

 ;     LRDFN = Lab Patient

 ;

 I $G(BLRARPHY)=""!($G(BLRARFL)="")!($G(LRIDT)="")!($G(LRDFN)="") Q

 ;

 ;S ^LR("BLRA",BLRARPHY,BLRARFL,-LRIDT,LRDFN)=LRSS

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

 S ^LR("BLRA",BLRARPHY,BLRARFL,-LRIDT,LRDFN,LRSS)=LRSS

 ;----- END IHS MODIFICATIONS

 Q

 ;

KX ;EP

 ;  Kill review cross-reference

 ;  ^LR("BLRA",BLRARPHY,BLRARFL,-LRIDT,LRDFN)

 ;     BLRARPHY  = Responsible Physician

 ;     BLRARFL = Review Status

 ;     LRIDT = Reverse Date

 ;     LRDFN = Lab Patient

 ;

 I $G(BLRARPHY)=""!($G(BLRARFL)="")!($G(LRIDT)="")!($G(LRDFN)="") Q

 ;

 ;K ^LR("BLRA",BLRARPHY,BLRARFL,-LRIDT,LRDFN)

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

 K ^LR("BLRA",BLRARPHY,BLRARFL,-LRIDT,LRDFN,LRSS)

 ;----- END IHS MODIFICATIONS

 Q

 ;

ALT ;  Generate alert message

 ;

 ;  If user is not found in the participating physician file

 ;  then they are not participating in the Electronic signature

 ;  modification.

 I '$D(^BLRALAB(9009027.1,DUZ)) Q

 ;

 ;  If user is an inactive participating physician, alert not shown

 I $P($G(^BLRALAB(9009027.1,DUZ,0)),U,7)="I" Q

 ;

 ;  Variables

 ;    BLRABC = Abnormal Count

 ;    BLRANC = Normal Count

 ;    BLRCRC = Critical Count

 ;    DUZ    = User

 S BLRABC=0,BLRANC=0,BLRCRC=0,BLRADUZ=DUZ D FND

 ;

 ;  Check for surrogates

 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

 ;

 I BLRANC'=0 D

 . W !!?5,"You have "_BLRANC_" Lab Results to Review" S BX=""

 I BLRCRC'=0 D

 . W !,?10," with "_BLRCRC_" CRITICAL"_$S(BLRCRC=1:"",1:"s")

 . S BX=" and"

 I BLRABC'=0 D

 . I BLRCRC=0 W !,?10

 . W BX_" with "_BLRABC_" ABNORMAL"_$S(BLRABC=1:"",1:"s")

 Q

 ;

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

 ... 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 BLRANC=BLRANC+1

 .... I +$P($G(^LR(BLRAP,BLRSS,BLRIDT,9009027)),U,8)'=0 S BLRCRC=BLRCRC+1 Q

 .... I $P($G(^LR(BLRAP,BLRSS,BLRIDT,9009027)),U,6)'=0 S BLRABC=BLRABC+1

 Q

HEAD ; Privacy warning message

 W @IOF

 F BLRAJ=0:1:3 D H1

 Q

 ;

H1 S BLRAX=$T(TEXT+BLRAJ),BLRAX=$P(BLRAX,";;",2)

 W !?80-$L(BLRAX)\2,BLRAX

 Q

TEXT ;;WARNING: RESTRICTED GOVERNMENT PATIENT DATA, UNAUTHORIZED

 ;;ENTRY INTO THIS SYSTEM OR USE OF THIS DATA IS A FEDERAL CRIME

 ;;****************************************************

BLRALUT1  ;DAOU/ALA-Lab ES Utility 

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

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

 +3       ;

 +4       ;**Program Description**

 +5       ;  This contains utilities for Lab Audit

 +6       ;

SX        ;EP

 +1       ;  Set review cross-reference

 +2       ;  ^LR("BLRA",BLRARPHY,BLRARFL,-LRIDT,LRDFN)

 +3       ;     BLRARPHY  = Responsible Physician

 +4       ;     BLRARFL = Review Status

 +5       ;             0 = Not Reviewed 

 +6       ;             1 = Reviewed, not signed 

 +7       ;             2 = Reviewed, signed

 +8       ;     LRIDT = Reverse Date

 +9       ;     LRDFN = Lab Patient

 +10      ;

 +11       IF $GET(BLRARPHY)=""!($GET(BLRARFL)="")!($GET(LRIDT)="")!($GET(LRDFN)="")

               QUIT 

 +12      ;

 +13      ;S ^LR("BLRA",BLRARPHY,BLRARFL,-LRIDT,LRDFN)=LRSS

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

 +15       SET ^LR("BLRA",BLRARPHY,BLRARFL,-LRIDT,LRDFN,LRSS)=LRSS

 +16      ;----- END IHS MODIFICATIONS

 +17       QUIT 

 +18      ;

KX        ;EP

 +1       ;  Kill review cross-reference

 +2       ;  ^LR("BLRA",BLRARPHY,BLRARFL,-LRIDT,LRDFN)

 +3       ;     BLRARPHY  = Responsible Physician

 +4       ;     BLRARFL = Review Status

 +5       ;     LRIDT = Reverse Date

 +6       ;     LRDFN = Lab Patient

 +7       ;

 +8        IF $GET(BLRARPHY)=""!($GET(BLRARFL)="")!($GET(LRIDT)="")!($GET(LRDFN)="")

               QUIT 

 +9       ;

 +10      ;K ^LR("BLRA",BLRARPHY,BLRARFL,-LRIDT,LRDFN)

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

 +12       KILL ^LR("BLRA",BLRARPHY,BLRARFL,-LRIDT,LRDFN,LRSS)

 +13      ;----- END IHS MODIFICATIONS

 +14       QUIT 

 +15      ;

ALT       ;  Generate alert message

 +1       ;

 +2       ;  If user is not found in the participating physician file

 +3       ;  then they are not participating in the Electronic signature

 +4       ;  modification.

 +5        IF '$DATA(^BLRALAB(9009027.1,DUZ))

               QUIT 

 +6       ;

 +7       ;  If user is an inactive participating physician, alert not shown

 +8        IF $PIECE($GET(^BLRALAB(9009027.1,DUZ,0)),U,7)="I"

               QUIT 

 +9       ;

 +10      ;  Variables

 +11      ;    BLRABC = Abnormal Count

 +12      ;    BLRANC = Normal Count

 +13      ;    BLRCRC = Critical Count

 +14      ;    DUZ    = User

 +15       SET BLRABC=0

           SET BLRANC=0

           SET BLRCRC=0

           SET BLRADUZ=DUZ

           DO FND

 +16      ;

 +17      ;  Check for surrogates

 +18       SET BLRADUZ=""

 +19       FOR 

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

               IF BLRADUZ=""

                   QUIT 

               Begin DoDot:1

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

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

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

                       QUIT 

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

                       DO FND

               End DoDot:1

 +24      ;

 +25       IF BLRANC'=0

               Begin DoDot:1

 +26               WRITE !!?5,"You have "_BLRANC_" Lab Results to Review"

                   SET BX=""

               End DoDot:1

 +27       IF BLRCRC'=0

               Begin DoDot:1

 +28               WRITE !,?10," with "_BLRCRC_" CRITICAL"_$SELECT(BLRCRC=1:"",1:"s")

 +29               SET BX=" and"

               End DoDot:1

 +30       IF BLRABC'=0

               Begin DoDot:1

 +31               IF BLRCRC=0

                       WRITE !,?10

 +32               WRITE BX_" with "_BLRABC_" ABNORMAL"_$SELECT(BLRABC=1:"",1:"s")

               End DoDot:1

 +33       QUIT 

 +34      ;

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                                SET BLRSS=""

 +10                               FOR 

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

                                       IF BLRSS=""

                                           QUIT 

                                       Begin DoDot:4

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

 +12      ;----- END IHS MODIFICATIONS

 +13                                       SET BLRANC=BLRANC+1

 +14                                       IF +$PIECE($GET(^LR(BLRAP,BLRSS,BLRIDT,9009027)),U,8)'=0

                                               SET BLRCRC=BLRCRC+1

                                               QUIT 

 +15                                       IF $PIECE($GET(^LR(BLRAP,BLRSS,BLRIDT,9009027)),U,6)'=0

                                               SET BLRABC=BLRABC+1

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +16       QUIT 

HEAD      ; Privacy warning message

 +1        WRITE @IOF

 +2        FOR BLRAJ=0:1:3

               DO H1

 +3        QUIT 

 +4       ;

H1         SET BLRAX=$TEXT(TEXT+BLRAJ)

           SET BLRAX=$PIECE(BLRAX,";;",2)

 +1        WRITE !?80-$LENGTH(BLRAX)\2,BLRAX

 +2        QUIT 

TEXT      ;;WARNING: RESTRICTED GOVERNMENT PATIENT DATA, UNAUTHORIZED

 +1       ;;ENTRY INTO THIS SYSTEM OR USE OF THIS DATA IS A FEDERAL CRIME

 +2       ;;****************************************************