Routine: BLRALBR

BLRALBR ;MTK/CR,ALA-List Template for Lab ESIG

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

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

EN ;

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

 . W !!,"YOU ARE NOT SET UP AS A PARTICIPATING PHYSICIAN FOR THE LAB ELECTRONIC",!

 . W "SIGNATURE MODULE.  PLEASE CONTACT YOUR SITE MANAGER.",!!

 ;  Sign electronic signature

 W !!,"You have 60 seconds before timeout to enter your electronic"

 W !,"signature for verification!!",!!

 D SIG^XUSESIG

 I X1="" Q

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

 . W !!,"     YOU ARE AN INACTIVE PHYSICIAN FOR THE LAB ESIG MODULE.",!

 . W "          PLEASE CONTACT YOUR SITE MANAGER.",!!

 D ^BLRALBL  ; Setup data into ^TMP("BLRA",$J) for list

 S BLRASCR="F" K BLRASUB

 D EN^BLRAL1  ; Call the list template to list labs

 K BENDT,BLRA0,BLRAAB,BLRABC,BLRACCN,BLRADATA,BLRADT,BLRADTT

 K BLRADUZ,BLRALINE,BLRALNUM,BLRALVAR,BLRANC,BLRAOPH,BLRAP

 K BLRAPD,BLRAPFL,BLRAPIEN,BLRAPNM,BLRAPRG,BLRAQFL,BLRARPHY

 K BLRAS,BLRASCR,BLRASRT,BLRASTA,BLRASTAT,BLRCRC,BLRCRTL

 K BLRIDT,BLRSS,BLRVD,BSTDT,DTOUT

REV ; Review Selected Lab Result

 S BLRAQFL=0

 N DIR

 S DIR("A")="Please select a lab result to view, by line #"

 S DIR(0)="L^1:"_VALMCNT D ^DIR K DIR

 I $D(DIRUT) K DIRUT D EXT Q

 I $G(DUOUT)!($G(DTOUT)) D EXT Q

 I $G(Y)<1 D EXT Q

 ;  Set up scratch global to perform next and previous

 K ^TMP("BLRASEL",$J)

 S CC="" F  S CC=$O(Y(CC)) Q:CC=""  D

 . S BB=Y(CC) F JJ=1:1 S AA=$P(BB,",",JJ) Q:AA=""  D

 .. S ^TMP("BLRASEL",$J,AA,0)=""

 .. I JJ=1 S BLRAFN=AA

 .. S BLRALFN=AA

 ;  Start with first one

 S BLRAV=0

AGN S BLRAV=$O(^TMP("BLRASEL",$J,BLRAV)) I BLRAV="" D RBLD Q

 I $G(BLRAQFL)=1 S BLRAV=BLRALFN G AGN

 K BLRASUB

 D BLD

 D EN^BLRASP

 D BLD1

 G AGN

BLD ;S ACC=$E($G(^TMP("BLRALST1",$J,BLRAV,0)),5,18)

 ;D FIX

 ;S ACN=BB

 K BLRAT,BLRADATE,BLRAPT,BLRAFLG

 S (BLRAT,BLRADATE,BLRAPT)="",BLRAFLG=0

 F  S BLRAT=$O(^TMP("BLRA",$J,BLRAT)) Q:BLRAT=""!(BLRAT="ZNODE")  D

 . F  S BLRADATE=$O(^TMP("BLRA",$J,BLRAT,BLRADATE)) Q:BLRADATE=""!(BLRAFLG>0)  D

 .. F  S BLRAPT=$O(^TMP("BLRA",$J,BLRAT,BLRADATE,BLRAPT)) Q:BLRAPT=""!(BLRAFLG>0)  D

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

 ... S BLRSS=""

 ... F  S BLRSS=$O(^TMP("BLRA",$J,BLRAT,BLRADATE,BLRAPT,BLRSS)) Q:BLRSS=""!(BLRAFLG>0)  D

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

 .... I $P($G(^TMP("BLRA",$J,BLRAT,BLRADATE,BLRAPT,BLRSS)),U,7)=BLRAV D

 ..... S ACN=$P($G(^TMP("BLRA",$J,BLRAT,BLRADATE,BLRAPT,BLRSS)),U)

 ..... S BLRAFLG=1

 S BLDATA=$G(^TMP("BLRA",$J,"ZNODE",ACN))

 S LRDFN=$P(BLDATA,U,1),LRSS=$P(BLDATA,U,2),LRIDT=$P(BLDATA,U,3)

 K LRDPF,BLRAT,BLRADATE,BLRAPT,BLRAFLG

 I $E(LRSS,1,2)="CH" D CH^BLRALBD

 I $E(LRSS,1,2)="MI" D MI^BLRALBD

 S VALMCNT=+$G(BLRADSP)

BLD1 ;  Set the reviewed flag

 D REVW^BLRALFN1

 I '$G(BLRASUB) D

 . K ^TMP("BLRALST1",$J)

 . D INIT^BLRAL1

 K BLRASUB

COTH ; Check Other Provider Results

 K ^TMP("BLRA",$J)

 S BLRASCR="O"

 D PSUR^BLRALBL

 D EN^BLRAL1

CSUB ; Check Subordinate Provider Results

 K ^TMP("BLRA",$J)

 S BLRASCR="S"

 D CSUP^BLRALBL

 D EN^BLRAL1

PATS ;  Patient Sort Display

 K ^TMP("BLRA",$J)

 S BLRASCR="P"

 D PATS^BLRALBL

 D EN^BLRAL1

EXT ;exit without update      ;

 S VALMBCK=""

 S EXIT=1

FIX ;FIX ACC NUMBER

 S LEN=$L(ACC)

FIX1 S AA=$E(ACC,LEN)

 I AA=" " S LEN=LEN-1 G FIX1

 S BB=$E(ACC,1,LEN)

NEXT ;  Get the next accession from the list

 S BLRAV=$O(^TMP("BLRASEL",$J,BLRAV)),BLRASUB=1

 I BLRAV="" S VALMSG="No Next Accession",VALMBCK="",BLRAV=BLRALFN D RE^VALM4 Q

 K VALMHDR,LRDPF

 D BLD

 S VALMBG=1

 D RE^VALM4

PREV ;  Get the previous accession from the list

 S BLRAV=$O(^TMP("BLRASEL",$J,BLRAV),-1),BLRASUB=1

 I (BLRAV<BLRAFN)!(BLRAV=BLRALFN) S VALMSG="No Previous Accession",VALMBCK="",BLRAV=BLRAFN D RE^VALM4 Q

 K VALMHDR,LRDPF

 D BLD

 S VALMBG=1

 D RE^VALM4

EXIT D BLD1

QUT ;  Quit

 S BLRAQFL=1,DTOUT=U

RBLD ;  Rebuild list

 K BLRAFN,BLRALFN

 S BLRAPRG=$S(BLRASCR="S":"D CSUP^BLRALBL",BLRASCR="O":"D PSUR^BLRALBL",BLRASCR="P":"D PATS^BLRALBL",1:"D SELF^BLRALBL")

 X BLRAPRG

 I '$G(BLRASUB) D

 . K ^TMP("BLRALST1",$J)

 . D INIT^BLRAL1

BLRALBR   ;MTK/CR,ALA-List Template for Lab ESIG

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

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

 +3       ;

EN        ;

 +1       ;

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

               Begin DoDot:1

 +3                WRITE !!,"YOU ARE NOT SET UP AS A PARTICIPATING PHYSICIAN FOR THE LAB ELECTRONIC",!

 +4                WRITE "SIGNATURE MODULE.  PLEASE CONTACT YOUR SITE MANAGER.",!!

               End DoDot:1

               QUIT

 +5       ;

 +6       ;  Sign electronic signature

 +7        WRITE !!,"You have 60 seconds before timeout to enter your electronic"

 +8        WRITE !,"signature for verification!!",!!

 +9       ;

 +10       DO SIG^XUSESIG

 +11       IF X1=""

               QUIT

 +12      ;

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

               Begin DoDot:1

 +14               WRITE !!,"     YOU ARE AN INACTIVE PHYSICIAN FOR THE LAB ESIG MODULE.",!

 +15               WRITE "          PLEASE CONTACT YOUR SITE MANAGER.",!!

               End DoDot:1

               QUIT

 +16      ; Setup data into ^TMP("BLRA",$J) for list

           DO ^BLRALBL

 +17       SET BLRASCR="F"

           KILL BLRASUB

 +18      ; Call the list template to list labs

           DO EN^BLRAL1

 +19      ;

 +20       KILL BENDT,BLRA0,BLRAAB,BLRABC,BLRACCN,BLRADATA,BLRADT,BLRADTT

 +21       KILL BLRADUZ,BLRALINE,BLRALNUM,BLRALVAR,BLRANC,BLRAOPH,BLRAP

 +22       KILL BLRAPD,BLRAPFL,BLRAPIEN,BLRAPNM,BLRAPRG,BLRAQFL,BLRARPHY

 +23       KILL BLRAS,BLRASCR,BLRASRT,BLRASTA,BLRASTAT,BLRCRC,BLRCRTL

 +24       KILL BLRIDT,BLRSS,BLRVD,BSTDT,DTOUT

 +25       QUIT

 +26      ;

REV       ; Review Selected Lab Result

 +1        SET BLRAQFL=0

 +2        NEW DIR

 +3        SET DIR("A")="Please select a lab result to view, by line #"

 +4        SET DIR(0)="L^1:"_VALMCNT

           DO ^DIR

           KILL DIR

 +5        IF $DATA(DIRUT)

               KILL DIRUT

               DO EXT

               QUIT

 +6        IF $GET(DUOUT)!($GET(DTOUT))

               DO EXT

               QUIT

 +7        IF $GET(Y)<1

               DO EXT

               QUIT

 +8       ;

 +9       ;  Set up scratch global to perform next and previous

 +10       KILL ^TMP("BLRASEL",$JOB)

 +11       SET CC=""

FOR

               SET CC=$ORDER(Y(CC))

               IF CC=""

                   QUIT

               Begin DoDot:1

 +12               SET BB=Y(CC)

                   FOR JJ=1:1

                       SET AA=$PIECE(BB,",",JJ)

                       IF AA=""

                           QUIT

                       Begin DoDot:2

 +13                       SET ^TMP("BLRASEL",$JOB,AA,0)=""

 +14                       IF JJ=1

                               SET BLRAFN=AA

 +15                       SET BLRALFN=AA

                       End DoDot:2

               End DoDot:1

 +16      ;

 +17      ;  Start with first one

 +18       SET BLRAV=0

AGN        SET BLRAV=$ORDER(^TMP("BLRASEL",$JOB,BLRAV))

           IF BLRAV=""

               DO RBLD

               QUIT

 +1        IF $GET(BLRAQFL)=1

               SET BLRAV=BLRALFN

               GOTO AGN

 +2        KILL BLRASUB

 +3        DO BLD

 +4        DO EN^BLRASP

 +5        DO BLD1

 +6        GOTO AGN

 +7       ;

BLD       ;S ACC=$E($G(^TMP("BLRALST1",$J,BLRAV,0)),5,18)

 +1       ;D FIX

 +2       ;S ACN=BB

 +3        KILL BLRAT,BLRADATE,BLRAPT,BLRAFLG

 +4        SET (BLRAT,BLRADATE,BLRAPT)=""

           SET BLRAFLG=0

 +5        FOR

               SET BLRAT=$ORDER(^TMP("BLRA",$JOB,BLRAT))

               IF BLRAT=""!(BLRAT="ZNODE")

                   QUIT

               Begin DoDot:1

 +6                FOR

                       SET BLRADATE=$ORDER(^TMP("BLRA",$JOB,BLRAT,BLRADATE))

                       IF BLRADATE=""!(BLRAFLG>0)

                           QUIT

                       Begin DoDot:2

 +7                        FOR

                               SET BLRAPT=$ORDER(^TMP("BLRA",$JOB,BLRAT,BLRADATE,BLRAPT))

                               IF BLRAPT=""!(BLRAFLG>0)

                                   QUIT

                               Begin DoDot:3

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

 +9                                SET BLRSS=""

 +10                               FOR

                                       SET BLRSS=$ORDER(^TMP("BLRA",$JOB,BLRAT,BLRADATE,BLRAPT,BLRSS))

                                       IF BLRSS=""!(BLRAFLG>0)

                                           QUIT

                                       Begin DoDot:4

 +11      ;----- END IHS MODIFICATIONS

 +12                                       IF $PIECE($GET(^TMP("BLRA",$JOB,BLRAT,BLRADATE,BLRAPT,BLRSS)),U,7)=BLRAV

                                               Begin DoDot:5

 +13                                               SET ACN=$PIECE($GET(^TMP("BLRA",$JOB,BLRAT,BLRADATE,BLRAPT,BLRSS)),U)

 +14                                               SET BLRAFLG=1

                                               End DoDot:5

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +15       SET BLDATA=$GET(^TMP("BLRA",$JOB,"ZNODE",ACN))

 +16       SET LRDFN=$PIECE(BLDATA,U,1)

           SET LRSS=$PIECE(BLDATA,U,2)

           SET LRIDT=$PIECE(BLDATA,U,3)

 +17       KILL LRDPF,BLRAT,BLRADATE,BLRAPT,BLRAFLG

 +18       IF $EXTRACT(LRSS,1,2)="CH"

               DO CH^BLRALBD

 +19       IF $EXTRACT(LRSS,1,2)="MI"

               DO MI^BLRALBD

 +20       SET VALMCNT=+$GET(BLRADSP)

 +21       QUIT

 +22      ;

BLD1      ;  Set the reviewed flag

 +1        DO REVW^BLRALFN1

 +2       ;

 +3        IF '$GET(BLRASUB)

               Begin DoDot:1

 +4                KILL ^TMP("BLRALST1",$JOB)

 +5                DO INIT^BLRAL1

               End DoDot:1

 +6        KILL BLRASUB

 +7        QUIT

COTH      ; Check Other Provider Results

 +1       ;

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

 +3        SET BLRASCR="O"

 +4        DO PSUR^BLRALBL

 +5        DO EN^BLRAL1

 +6        QUIT

 +7       ;

CSUB      ; Check Subordinate Provider Results

 +1       ;

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

 +3        SET BLRASCR="S"

 +4        DO CSUP^BLRALBL

 +5        DO EN^BLRAL1

 +6        QUIT

 +7       ;

PATS      ;  Patient Sort Display

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

 +2        SET BLRASCR="P"

 +3        DO PATS^BLRALBL

 +4        DO EN^BLRAL1

 +5        QUIT

 +6       ;

EXT       ;exit without update      ;

 +1        SET VALMBCK=""

 +2        SET EXIT=1

 +3        QUIT

FIX       ;FIX ACC NUMBER

 +1        SET LEN=$LENGTH(ACC)

FIX1       SET AA=$EXTRACT(ACC,LEN)

 +1        IF AA=" "

               SET LEN=LEN-1

               GOTO FIX1

 +2        SET BB=$EXTRACT(ACC,1,LEN)

 +3        QUIT

 +4       ;

NEXT      ;  Get the next accession from the list

 +1        SET BLRAV=$ORDER(^TMP("BLRASEL",$JOB,BLRAV))

           SET BLRASUB=1

 +2        IF BLRAV=""

               SET VALMSG="No Next Accession"

               SET VALMBCK=""

               SET BLRAV=BLRALFN

               DO RE^VALM4

               QUIT

 +3        KILL VALMHDR,LRDPF

 +4        DO BLD

 +5        SET VALMBG=1

 +6        DO RE^VALM4

 +7        QUIT

 +8       ;

PREV      ;  Get the previous accession from the list

 +1        SET BLRAV=$ORDER(^TMP("BLRASEL",$JOB,BLRAV),-1)

           SET BLRASUB=1

 +2        IF (BLRAV<BLRAFN)!(BLRAV=BLRALFN)

               SET VALMSG="No Previous Accession"

               SET VALMBCK=""

               SET BLRAV=BLRAFN

               DO RE^VALM4

               QUIT

 +3        KILL VALMHDR,LRDPF

 +4        DO BLD

 +5        SET VALMBG=1

 +6        DO RE^VALM4

 +7        QUIT

EXIT       DO BLD1

 +1        QUIT

QUT       ;  Quit

 +1        SET BLRAQFL=1

           SET DTOUT=U

 +2        QUIT

 +3       ;

RBLD      ;  Rebuild list

 +1        KILL BLRAFN,BLRALFN

 +2        SET BLRAPRG=$SELECT(BLRASCR="S":"D CSUP^BLRALBL",BLRASCR="O":"D PSUR^BLRALBL",BLRASCR="P":"D PATS^BLRALBL",1:"D SELF^BLRALBL")

 +3        XECUTE BLRAPRG

 +4        IF '$GET(BLRASUB)

               Begin DoDot:1

 +5                KILL ^TMP("BLRALST1",$JOB)

 +6                DO INIT^BLRAL1

               End DoDot:1

 +7        QUIT

BLRALBR.m