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
Q
;
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)
Q
;
BLD1 ; Set the reviewed flag
D REVW^BLRALFN1
;
I '$G(BLRASUB) D
. K ^TMP("BLRALST1",$J)
. D INIT^BLRAL1
K BLRASUB
Q
COTH ; Check Other Provider Results
;
K ^TMP("BLRA",$J)
S BLRASCR="O"
D PSUR^BLRALBL
D EN^BLRAL1
Q
;
CSUB ; Check Subordinate Provider Results
;
K ^TMP("BLRA",$J)
S BLRASCR="S"
D CSUP^BLRALBL
D EN^BLRAL1
Q
;
PATS ; Patient Sort Display
K ^TMP("BLRA",$J)
S BLRASCR="P"
D PATS^BLRALBL
D EN^BLRAL1
Q
;
EXT ;exit without update ;
S VALMBCK=""
S EXIT=1
Q
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)
Q
;
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
Q
;
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
Q
EXIT D BLD1
Q
QUT ; Quit
S BLRAQFL=1,DTOUT=U
Q
;
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
Q
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
