LRVER3 ;DALOI/STAFF - DATA VERIFICATION ;05/10/11 13:50
;;5.2;LAB SERVICE;**42,100,121,140,171,153,221,286,291,406,350,461,499**;Sep 27, 1994;Build 2
;
D V1
I $D(LRLOCKER)#2 L -@(LRLOCKER) K LRLOCKER
Q
;
;
V1 ;
;
I $D(LRLOCKER)#2 L -@(LRLOCKER)
S LRLOCKER="^LR("_LRDFN_","""_LRSS_""","_LRIDT_")"
D LOCK^DILF(LRLOCKER) ; L +@(LRLOCKER):DILOCKTM
I '$T W !," This entry is being edited by someone else." Q
;
I $D(LRGVP) S X="1-"_LRNTN D RANGE^LRWU2 G L10
S LRALL="",LRALERT=LROUTINE,LRLCT=6
;
; List any not performed or merged tests.
S I=0
F S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<1 D
. S LRX=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I,0))
. I $P(LRX,"^",6)'="*Not Performed",$P(LRX,"^",6)'="*Merged" Q
. W !,?3,$P(^LAB(60,I,0),"^"),?25," ",$P(LRX,"^",6)
. S LRLCT=LRLCT+1 D:LRLCT>22 WT^LRVER4
;
; No tests to edit
I LRNTN=0 D COM^LRVR4 G EXIT
;
F I=1:1:LRNTN I $D(LRNAME(I)) D
. S LRALL=LRALL_","_I W !,I," ",LRNAME(I)
. I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,$O(LRNAME(I,0)),0))#2 D
. . S LRX=^LRO(68,LRAA,1,LRAD,1,LRAN,4,$O(LRNAME(I,0)),0)
. . S LRAL=$P(LRX,U,2)#50
. . I $P(LRX,U,5) W ?25,$S($P(LRX,U,6)'="":$P(LRX,U,6),1:" verified")
. . I LRAL S LRALERT=$S(LRAL<LRALERT:LRAL,1:LRALERT)
. S LRLCT=LRLCT+1 D:LRLCT>22 WT^LRVER4
;
I $D(LRALERT),LRALERT<($P(LRPARAM,U,20)+1) D
. W !?15 W:IOST["C-" @LRVIDO
. W "Test ordered "_$P($G(^LAB(62.05,+LRALERT,0)),U)
. W:IOST["C-" @LRVIDOF W !,$C(7)
;
S X9="" I LRNTN=1 S T1=1 G L10
V9 S LRALL=$P(LRALL,",",2,99)
R !!,"TEST #(s) (or ""ALL""): ",X:DTIME S:'$T X=U S:X["A" X=LRALL
I X["?" W !,"Enter for example 1,2,5-9." G V9
Q:X[U!(X="") D RANGE^LRWU2 G EXIT:X9="" X (X9_"S:'$D(LRNAME(T1)) X=0") G EXIT:X=0
;
L10 ;
N LRCORECT S LRCORECT=0
S LRNX=0 X (X9_"D EX1^LRVER1")
;
; Calculate days back for delta check based on specimen collection date/time.
S LRTM60=$$LRTM60^LRVR(LRCDT)
D V7^LRVER2
;
S LRCMTDSP=$$CHKCDSP^LRVERA
K LRSA,LRSB,LRORU3
F LRSB=1:0 S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:LRSB<1 D
. S LRSB(LRSB)=^(LRSB),LRSB(LRSB,"P")=$P(LRSB(LRSB),U,3)
. I $D(LRNOVER) S LRNOVER(LRSB)=""
S LREDIT=1
D ^LRVER4
;
; If group data review then quit before updating results
I $D(LRGVP) G EXIT
;
I '$O(LRORD(0)) G EXIT
;
; Set reporting site in file #63.
D SETRL^LRVERA(LRDFN,LRSS,LRIDT,DUZ(2))
;
I '$G(LRCHG),'LRVF D
. N LRNOW S LRNOW=$$NOW^XLFDT
. F LRSB=1:0 S LRSB=$O(LRSB(LRSB)) Q:LRSB<1 I $P(LRSB(LRSB),"^")'="" D
. . S $P(LRSB(LRSB),U,6)=LRNOW
. . S ^LR(LRDFN,LRSS,LRIDT,LRSB)=LRSB(LRSB)
;
I $G(LRCHG) D CHG K LRCHG,LRUP I $G(LREND) S LREND=0 D ASKXQA,EXIT Q
;
I $D(LRSA),$D(LRF) D Q
. K LRF
. S X=$P(^LR(LRDFN,LRSS,LRIDT,0),U,9)
. S:$L(X)&($E(X)'["-") $P(^(0),U,9)="-"_X
. D V11,ASKXQA
;
;G EXIT:$D(LRGVP),V11:LRVF&$D(LRSA),V1:LRVF&(LRNTN>1),EXIT:LRVF
I $D(LRGVP) D EXIT Q
I LRVF,$D(LRSA) D V11,ASKXQA Q
I LRVF,LRNTN>1 D V1 Q
I LRVF D ASKXQA,EXIT Q
;
NOVER ;
I $O(LRNOVER(0)) D G EXIT
. N LRI,LRX
. S LRI=1
. F S LRI=+$O(LRNOVER(LRI)) Q:LRI<2 D
. . N LRX,LRERR
. . S LRX="Test Not Reviewed: "_$$GET1^DID(63.04,LRI,"","LABEL","","LRERR")
. . I $G(LRERR("DIERR",1)) W !,"For DATANAME "_LRI_" - "_LRERR("DIERR",1,"TEXT",1) Q
. . W !,LRX
. . I $D(LRSB(LRI))#2 W " = "_$P(LRSB(LRI),U)_" "_$P(LRSB(LRI),U,2)
. W !,$$CJ^XLFSTR("The above test(s) have results already entered,",IOM)
. W !,$$CJ^XLFSTR("but you did not select them for review.",IOM)
. W !,$$CJ^XLFSTR(" Accession NOT approved. ",IOM),$C(7)
. W !,$$CJ^XLFSTR("You must review all results before ANY can be released.",IOM),!!
. W:$E(IOST,1,2)="C-" @LRVIDO
. W $$CJ^XLFSTR("Suggest you select 'ALL' tests for verification/review. ",IOM)
. W:$E(IOST,1,2)="C-" @LRVIDOF W !,$C(7)
I $O(LRNOVER(0)) W !,"Has not been reviewed and have data. Not approved.",! G EXIT
I '$P($G(LRLABKY),U) W !,$C(7),"ENTERED BUT NOT APPROVED",! G EXIT
I '$O(LRSB(0)) W !?5,"Nothing verified ",$C(7),! G EXIT
N CNT S CNT=1
;
AGAIN ;
R !,"Approve for release by entering your initials: ",LRINI:DTIME
I $E(LRINI)="^"!(LRINI="") W !!?5,$C(7),"Nothing verified!" D READ G EXIT
I LRINI'=LRUSI,$$UP^XLFSTR(LRINI)=$$UP^XLFSTR(LRUSI) S LRINI=LRUSI
I $S($E(LRINI)="?":1,LRINI'=LRUSI&(CNT<2):1,1:0) W !,$C(7),"Please enter your correct initials" S:$E(LRINI)="?" CNT=0 S CNT=CNT+1 G AGAIN
I LRINI'=LRUSI W !!?5,$C(7),"Nothing verified!" D READ G EXIT
D V11
D ASKXQA
Q
;
;
V11 ;
I $D(XRTL) D T0^%ZOSV ; START RESPONSE TIME LOGGING
I +LRDPF=2&($G(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT)) D
.D BAWRK^LRBEBA(LRODT,LRSN,1,.LRBEY,.LRTEST)
D VER^LRVER3A
I $P(LRPARAM,U,14),$P($G(^LRO(68,LRAA,0)),U,16) D LOOK^LRCAPV1
N LRX
S LRX=0
F S LRX=$O(^TMP("LR",$J,"TMP",LRX)) Q:LRX<1 S:'$D(^LRO(68,"AC",LRDFN,LRIDT,LRX)) ^(LRX)="" I LRVF S ^(LRX)=""
I $P($G(LRORU3),U,3),$O(LRSB(0)) D LRORU3
I $D(XRT0) S XRTN="V11^LRVER3" D T1^%ZOSV ; STOP RESPONSE TIME LOGGING
S LRVF=1
Q
;
;
EXIT Q
;
;
READ ;
N X W !!,"Press ENTER or RETURN to continue: " R X:DTIME
Q
;
;
CHG ; Check for changes, save results and create audit trail
N LRNOW
S LRUP="",LRNOW=$$NOW^XLFDT
F S LRCHG=$O(LRSB(LRCHG)) Q:LRCHG<1 D
. I '$D(LRSA(LRCHG)) S LRUP=1 Q
. I $P(LRSA(LRCHG),"^")=""!($P(LRSA(LRCHG),"^")="pending") D Q ; Update user/release time/performing lab if results entered.
. . S LRSA(LRCHG,3)=1
. . S LRUP=1
. . S $P(LRSB(LRCHG),U,4)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ))
. . S $P(LRSB(LRCHG),U,6)=LRNOW
. . S $P(LRSB(LRCHG),U,9)=$S($G(LRDUZ(2)):LRDUZ(2),$G(DUZ(2)):DUZ(2),1:"")
. I $P(LRSA(LRCHG),"^")'=$P(LRSB(LRCHG),"^") S LRUP=1,$P(LRSA(LRCHG,2),"^")=1 ; results changed
. I $P(LRSA(LRCHG),"^",2)'=$P(LRSB(LRCHG),"^",2) S LRUP=1,$P(LRSA(LRCHG,2),"^",2)=1 ; normalcy flag changed
. I $P(LRSA(LRCHG),"^",5)'=$P(LRSB(LRCHG),"^",5) D ; units/normals changed
. . N LRX,LRY
. . S LRX=$$UP^XLFSTR($P(LRSA(LRCHG),"^",5)),LRX=$TR(LRX,"""")
. . S LRY=$$UP^XLFSTR($P(LRSB(LRCHG),"^",5)),LRY=$TR(LRY,"""")
. . I LRX'=LRY S LRUP=1,$P(LRSA(LRCHG,2),"^",5)=1
. I $D(LRSA(LRCHG,2)) D ; Update user/release time/performing lab if results changed.
. . S $P(LRSB(LRCHG),U,4)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ))
. . S $P(LRSB(LRCHG),U,6)=LRNOW
. . S $P(LRSB(LRCHG),U,9)=$S($G(LRDUZ(2)):LRDUZ(2),$G(DUZ(2)):DUZ(2),1:"")
I 'LRUP S LREND=1 Q
S LREND=0
W !! W:IOST["C-" @LRVIDO W "Approve update of data by entering your initials: " W:IOST["C-" @LRVIDOF
R LRINI:DTIME
I '$T S LREND=1
I 'LREND,LRINI'=LRUSI,$$UP^XLFSTR(LRINI)=$$UP^XLFSTR(LRUSI) S LRINI=LRUSI
I LRINI'=LRUSI S LREND=1
I LREND W !,$C(7),"No updating occurred ",! Q
;
F LRSB=1:0 S LRSB=$O(LRSB(LRSB)) Q:LRSB<1 D
. K:'$D(^LR(LRDFN,LRSS,LRIDT,LRSB)) LRSA(LRSB)
. I $P(LRSB(LRSB),"^")'="" S ^LR(LRDFN,LRSS,LRIDT,LRSB)=LRSB(LRSB)
. I $D(LRSA(LRSB,1)),$D(LRSA(LRSB,2)) D DIDLE
;
W !!
Q
;
;
DIDLE ;
; Check if no previous result or pending result - no audit trail needed
I $P(LRSA(LRSB),"^")=""!($P(LRSA(LRSB),"^")="pending") Q
;
S LRF=1
L +^LR(LRDFN,LRSS,LRIDT):DILOCKTM+999
NOW ;
N LRNOW7
S LRNOW7=$S($G(LRNOW):LRNOW,1:$$NOW^XLFDT)
W !
D ^LRDIDLE0
I 'LROK K LRSA
L -^LR(LRDFN,LRSS,LRIDT)
S LRCORECT=1
Q
;
;
RONLT ; (R)esolve (O)rder NLT code from file #68 original ordered test or
; use default when not specified for file #60 test.
;
N LR60,LRX,LRY,X
S LR60=+LRTS,LRY=$P(LRSB(LRSB),U,3)
;
; Try to determine order NLT from original ordered test
F Q:'LR60 D
. S LRX=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LR60,0)),LR60=+$P(LRX,"^",9)
. I LR60,LR60'=$P(LRX,"^") D
. . S X=$$NLT^LRVER1(LR60)
. . I X'="" S $P(LRY,"!")=X
. I LR60=$P(LRX,"^") S LR60=0
;
; Otherwise use default for lab package
I $P(LRY,"!")="" S $P(LRY,"!")=$P($$DEFCODE^LA7VHLU5(LRSS,LRSB,LRY,+LRSPEC),"!")
;
S $P(LRSB(LRSB),U,3)=LRY
;
Q
;
;
LRORU3 ;
SET ;
N LR64,LR7V,LRDN,LROTA,LRT,LRTPN,LRTPNN,LRTYPE,X
;
; Go through LRSB array and sort results by order NLT code
; and put into ordered test array (LROTA).
S LRDN=0
F S LRDN=$O(LRSB(LRDN)) Q:'LRDN D
. I $P(LRSB(LRDN),"^")="" Q
. S LRTPNN=$P($P(LRSB(LRDN),U,3),"!"),LRT=+$G(^TMP("LR",$J,"TMP",LRDN))
. I LRTPNN="" Q
. S LRTYPE=$P($G(^LAB(60,LRT,0)),U,3)
. I LRTYPE=""!("OB"'[LRTYPE) Q
. S LROTA(LRTPNN,LRDN)=LRT
. I $D(LRSA(LRDN,2)) S LROTA(LRTPNN,LRDN,1)="C"
;
; For each order NLT code setup call to put results into #62.49 queue
S LRTPNN=""
F S LRTPNN=$O(LROTA(LRTPNN)) Q:LRTPNN="" D
. S LR64=+$O(^LAM("C",LRTPNN_" ",0)),LRTPN=$$GET1^DIQ(64,LR64_",",.01)
. K LR7V
. M LR7V=LROTA(LRTPNN)
. D SET^LA7VMSG($P(LRORU3,U,4),$P(LRORU3,U,2),$P(LRORU3,U,5),$P(LRORU3,U,3),LRTPN,LRTPNN,LRIDT,LRSS,LRDFN,LRODT,.LR7V,"ORU")
Q
;
;
ASKXQA ; Determine if user should be asked to send CPRS Alert
;
N LRDEFAULT
;
; No CPRS alert for non-PATIENT file (#2) patients
I +LRDPF'=2 Q
;
S LRDEFAULT=$$GET^XPAR("USR^DIV^PKG","LR CH VERIFY CPRS ALERT",1,"Q")
I LRDEFAULT>0 D ASKXQA^LR7ORB3(LRDFN,"CH",LRIDT,LRUID,LRDEFAULT)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVER3 9105 printed Apr 09, 2024@21:21:32 Page 2
LRVER3 ;DALOI/STAFF - DATA VERIFICATION ;05/10/11 13:50
+1 ;;5.2;LAB SERVICE;**42,100,121,140,171,153,221,286,291,406,350,461,499**;Sep 27, 1994;Build 2
+2 ;
+3 DO V1
+4 IF $DATA(LRLOCKER)#2
LOCK -@(LRLOCKER)
KILL LRLOCKER
+5 QUIT
+6 ;
+7 ;
V1 ;
+1 ;
+2 IF $DATA(LRLOCKER)#2
LOCK -@(LRLOCKER)
+3 SET LRLOCKER="^LR("_LRDFN_","""_LRSS_""","_LRIDT_")"
+4 ; L +@(LRLOCKER):DILOCKTM
DO LOCK^DILF(LRLOCKER)
+5 IF '$TEST
WRITE !," This entry is being edited by someone else."
QUIT
+6 ;
+7 IF $DATA(LRGVP)
SET X="1-"_LRNTN
DO RANGE^LRWU2
GOTO L10
+8 SET LRALL=""
SET LRALERT=LROUTINE
SET LRLCT=6
+9 ;
+10 ; List any not performed or merged tests.
+11 SET I=0
+12 FOR
SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I))
if I<1
QUIT
Begin DoDot:1
+13 SET LRX=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I,0))
+14 IF $PIECE(LRX,"^",6)'="*Not Performed"
IF $PIECE(LRX,"^",6)'="*Merged"
QUIT
+15 WRITE !,?3,$PIECE(^LAB(60,I,0),"^"),?25," ",$PIECE(LRX,"^",6)
+16 SET LRLCT=LRLCT+1
if LRLCT>22
DO WT^LRVER4
End DoDot:1
+17 ;
+18 ; No tests to edit
+19 IF LRNTN=0
DO COM^LRVR4
GOTO EXIT
+20 ;
+21 FOR I=1:1:LRNTN
IF $DATA(LRNAME(I))
Begin DoDot:1
+22 SET LRALL=LRALL_","_I
WRITE !,I," ",LRNAME(I)
+23 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,$ORDER(LRNAME(I,0)),0))#2
Begin DoDot:2
+24 SET LRX=^LRO(68,LRAA,1,LRAD,1,LRAN,4,$ORDER(LRNAME(I,0)),0)
+25 SET LRAL=$PIECE(LRX,U,2)#50
+26 IF $PIECE(LRX,U,5)
WRITE ?25,$SELECT($PIECE(LRX,U,6)'="":$PIECE(LRX,U,6),1:" verified")
+27 IF LRAL
SET LRALERT=$SELECT(LRAL<LRALERT:LRAL,1:LRALERT)
End DoDot:2
+28 SET LRLCT=LRLCT+1
if LRLCT>22
DO WT^LRVER4
End DoDot:1
+29 ;
+30 IF $DATA(LRALERT)
IF LRALERT<($PIECE(LRPARAM,U,20)+1)
Begin DoDot:1
+31 WRITE !?15
if IOST["C-"
WRITE @LRVIDO
+32 WRITE "Test ordered "_$PIECE($GET(^LAB(62.05,+LRALERT,0)),U)
+33 if IOST["C-"
WRITE @LRVIDOF
WRITE !,$CHAR(7)
End DoDot:1
+34 ;
+35 SET X9=""
IF LRNTN=1
SET T1=1
GOTO L10
V9 SET LRALL=$PIECE(LRALL,",",2,99)
+1 READ !!,"TEST #(s) (or ""ALL""): ",X:DTIME
if '$TEST
SET X=U
if X["A"
SET X=LRALL
+2 IF X["?"
WRITE !,"Enter for example 1,2,5-9."
GOTO V9
+3 if X[U!(X="")
QUIT
DO RANGE^LRWU2
if X9=""
GOTO EXIT
XECUTE (X9_"S:'$D(LRNAME(T1)) X=0")
if X=0
GOTO EXIT
+4 ;
L10 ;
+1 NEW LRCORECT
SET LRCORECT=0
+2 SET LRNX=0
XECUTE (X9_"D EX1^LRVER1")
+3 ;
+4 ; Calculate days back for delta check based on specimen collection date/time.
+5 SET LRTM60=$$LRTM60^LRVR(LRCDT)
+6 DO V7^LRVER2
+7 ;
+8 SET LRCMTDSP=$$CHKCDSP^LRVERA
+9 KILL LRSA,LRSB,LRORU3
+10 FOR LRSB=1:0
SET LRSB=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRSB))
if LRSB<1
QUIT
Begin DoDot:1
+11 SET LRSB(LRSB)=^(LRSB)
SET LRSB(LRSB,"P")=$PIECE(LRSB(LRSB),U,3)
+12 IF $DATA(LRNOVER)
SET LRNOVER(LRSB)=""
End DoDot:1
+13 SET LREDIT=1
+14 DO ^LRVER4
+15 ;
+16 ; If group data review then quit before updating results
+17 IF $DATA(LRGVP)
GOTO EXIT
+18 ;
+19 IF '$ORDER(LRORD(0))
GOTO EXIT
+20 ;
+21 ; Set reporting site in file #63.
+22 DO SETRL^LRVERA(LRDFN,LRSS,LRIDT,DUZ(2))
+23 ;
+24 IF '$GET(LRCHG)
IF 'LRVF
Begin DoDot:1
+25 NEW LRNOW
SET LRNOW=$$NOW^XLFDT
+26 FOR LRSB=1:0
SET LRSB=$ORDER(LRSB(LRSB))
if LRSB<1
QUIT
IF $PIECE(LRSB(LRSB),"^")'=""
Begin DoDot:2
+27 SET $PIECE(LRSB(LRSB),U,6)=LRNOW
+28 SET ^LR(LRDFN,LRSS,LRIDT,LRSB)=LRSB(LRSB)
End DoDot:2
End DoDot:1
+29 ;
+30 IF $GET(LRCHG)
DO CHG
KILL LRCHG,LRUP
IF $GET(LREND)
SET LREND=0
DO ASKXQA
DO EXIT
QUIT
+31 ;
+32 IF $DATA(LRSA)
IF $DATA(LRF)
Begin DoDot:1
+33 KILL LRF
+34 SET X=$PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,9)
+35 if $LENGTH(X)&($EXTRACT(X)'["-")
SET $PIECE(^(0),U,9)="-"_X
+36 DO V11
DO ASKXQA
End DoDot:1
QUIT
+37 ;
+38 ;G EXIT:$D(LRGVP),V11:LRVF&$D(LRSA),V1:LRVF&(LRNTN>1),EXIT:LRVF
+39 IF $DATA(LRGVP)
DO EXIT
QUIT
+40 IF LRVF
IF $DATA(LRSA)
DO V11
DO ASKXQA
QUIT
+41 IF LRVF
IF LRNTN>1
DO V1
QUIT
+42 IF LRVF
DO ASKXQA
DO EXIT
QUIT
+43 ;
NOVER ;
+1 IF $ORDER(LRNOVER(0))
Begin DoDot:1
+2 NEW LRI,LRX
+3 SET LRI=1
+4 FOR
SET LRI=+$ORDER(LRNOVER(LRI))
if LRI<2
QUIT
Begin DoDot:2
+5 NEW LRX,LRERR
+6 SET LRX="Test Not Reviewed: "_$$GET1^DID(63.04,LRI,"","LABEL","","LRERR")
+7 IF $GET(LRERR("DIERR",1))
WRITE !,"For DATANAME "_LRI_" - "_LRERR("DIERR",1,"TEXT",1)
QUIT
+8 WRITE !,LRX
+9 IF $DATA(LRSB(LRI))#2
WRITE " = "_$PIECE(LRSB(LRI),U)_" "_$PIECE(LRSB(LRI),U,2)
End DoDot:2
+10 WRITE !,$$CJ^XLFSTR("The above test(s) have results already entered,",IOM)
+11 WRITE !,$$CJ^XLFSTR("but you did not select them for review.",IOM)
+12 WRITE !,$$CJ^XLFSTR(" Accession NOT approved. ",IOM),$CHAR(7)
+13 WRITE !,$$CJ^XLFSTR("You must review all results before ANY can be released.",IOM),!!
+14 if $EXTRACT(IOST,1,2)="C-"
WRITE @LRVIDO
+15 WRITE $$CJ^XLFSTR("Suggest you select 'ALL' tests for verification/review. ",IOM)
+16 if $EXTRACT(IOST,1,2)="C-"
WRITE @LRVIDOF
WRITE !,$CHAR(7)
End DoDot:1
GOTO EXIT
+17 IF $ORDER(LRNOVER(0))
WRITE !,"Has not been reviewed and have data. Not approved.",!
GOTO EXIT
+18 IF '$PIECE($GET(LRLABKY),U)
WRITE !,$CHAR(7),"ENTERED BUT NOT APPROVED",!
GOTO EXIT
+19 IF '$ORDER(LRSB(0))
WRITE !?5,"Nothing verified ",$CHAR(7),!
GOTO EXIT
+20 NEW CNT
SET CNT=1
+21 ;
AGAIN ;
+1 READ !,"Approve for release by entering your initials: ",LRINI:DTIME
+2 IF $EXTRACT(LRINI)="^"!(LRINI="")
WRITE !!?5,$CHAR(7),"Nothing verified!"
DO READ
GOTO EXIT
+3 IF LRINI'=LRUSI
IF $$UP^XLFSTR(LRINI)=$$UP^XLFSTR(LRUSI)
SET LRINI=LRUSI
+4 IF $SELECT($EXTRACT(LRINI)="?":1,LRINI'=LRUSI&(CNT<2):1,1:0)
WRITE !,$CHAR(7),"Please enter your correct initials"
if $EXTRACT(LRINI)="?"
SET CNT=0
SET CNT=CNT+1
GOTO AGAIN
+5 IF LRINI'=LRUSI
WRITE !!?5,$CHAR(7),"Nothing verified!"
DO READ
GOTO EXIT
+6 DO V11
+7 DO ASKXQA
+8 QUIT
+9 ;
+10 ;
V11 ;
+1 ; START RESPONSE TIME LOGGING
IF $DATA(XRTL)
DO T0^%ZOSV
+2 IF +LRDPF=2&($GET(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT))
Begin DoDot:1
+3 DO BAWRK^LRBEBA(LRODT,LRSN,1,.LRBEY,.LRTEST)
End DoDot:1
+4 DO VER^LRVER3A
+5 IF $PIECE(LRPARAM,U,14)
IF $PIECE($GET(^LRO(68,LRAA,0)),U,16)
DO LOOK^LRCAPV1
+6 NEW LRX
+7 SET LRX=0
+8 FOR
SET LRX=$ORDER(^TMP("LR",$JOB,"TMP",LRX))
if LRX<1
QUIT
if '$DATA(^LRO(68,"AC",LRDFN,LRIDT,LRX))
SET ^(LRX)=""
IF LRVF
SET ^(LRX)=""
+9 IF $PIECE($GET(LRORU3),U,3)
IF $ORDER(LRSB(0))
DO LRORU3
+10 ; STOP RESPONSE TIME LOGGING
IF $DATA(XRT0)
SET XRTN="V11^LRVER3"
DO T1^%ZOSV
+11 SET LRVF=1
+12 QUIT
+13 ;
+14 ;
EXIT QUIT
+1 ;
+2 ;
READ ;
+1 NEW X
WRITE !!,"Press ENTER or RETURN to continue: "
READ X:DTIME
+2 QUIT
+3 ;
+4 ;
CHG ; Check for changes, save results and create audit trail
+1 NEW LRNOW
+2 SET LRUP=""
SET LRNOW=$$NOW^XLFDT
+3 FOR
SET LRCHG=$ORDER(LRSB(LRCHG))
if LRCHG<1
QUIT
Begin DoDot:1
+4 IF '$DATA(LRSA(LRCHG))
SET LRUP=1
QUIT
+5 ; Update user/release time/performing lab if results entered.
IF $PIECE(LRSA(LRCHG),"^")=""!($PIECE(LRSA(LRCHG),"^")="pending")
Begin DoDot:2
+6 SET LRSA(LRCHG,3)=1
+7 SET LRUP=1
+8 SET $PIECE(LRSB(LRCHG),U,4)=$SELECT($GET(LRDUZ):LRDUZ,1:$GET(DUZ))
+9 SET $PIECE(LRSB(LRCHG),U,6)=LRNOW
+10 SET $PIECE(LRSB(LRCHG),U,9)=$SELECT($GET(LRDUZ(2)):LRDUZ(2),$GET(DUZ(2)):DUZ(2),1:"")
End DoDot:2
QUIT
+11 ; results changed
IF $PIECE(LRSA(LRCHG),"^")'=$PIECE(LRSB(LRCHG),"^")
SET LRUP=1
SET $PIECE(LRSA(LRCHG,2),"^")=1
+12 ; normalcy flag changed
IF $PIECE(LRSA(LRCHG),"^",2)'=$PIECE(LRSB(LRCHG),"^",2)
SET LRUP=1
SET $PIECE(LRSA(LRCHG,2),"^",2)=1
+13 ; units/normals changed
IF $PIECE(LRSA(LRCHG),"^",5)'=$PIECE(LRSB(LRCHG),"^",5)
Begin DoDot:2
+14 NEW LRX,LRY
+15 SET LRX=$$UP^XLFSTR($PIECE(LRSA(LRCHG),"^",5))
SET LRX=$TRANSLATE(LRX,"""")
+16 SET LRY=$$UP^XLFSTR($PIECE(LRSB(LRCHG),"^",5))
SET LRY=$TRANSLATE(LRY,"""")
+17 IF LRX'=LRY
SET LRUP=1
SET $PIECE(LRSA(LRCHG,2),"^",5)=1
End DoDot:2
+18 ; Update user/release time/performing lab if results changed.
IF $DATA(LRSA(LRCHG,2))
Begin DoDot:2
+19 SET $PIECE(LRSB(LRCHG),U,4)=$SELECT($GET(LRDUZ):LRDUZ,1:$GET(DUZ))
+20 SET $PIECE(LRSB(LRCHG),U,6)=LRNOW
+21 SET $PIECE(LRSB(LRCHG),U,9)=$SELECT($GET(LRDUZ(2)):LRDUZ(2),$GET(DUZ(2)):DUZ(2),1:"")
End DoDot:2
End DoDot:1
+22 IF 'LRUP
SET LREND=1
QUIT
+23 SET LREND=0
+24 WRITE !!
if IOST["C-"
WRITE @LRVIDO
WRITE "Approve update of data by entering your initials: "
if IOST["C-"
WRITE @LRVIDOF
+25 READ LRINI:DTIME
+26 IF '$TEST
SET LREND=1
+27 IF 'LREND
IF LRINI'=LRUSI
IF $$UP^XLFSTR(LRINI)=$$UP^XLFSTR(LRUSI)
SET LRINI=LRUSI
+28 IF LRINI'=LRUSI
SET LREND=1
+29 IF LREND
WRITE !,$CHAR(7),"No updating occurred ",!
QUIT
+30 ;
+31 FOR LRSB=1:0
SET LRSB=$ORDER(LRSB(LRSB))
if LRSB<1
QUIT
Begin DoDot:1
+32 if '$DATA(^LR(LRDFN,LRSS,LRIDT,LRSB))
KILL LRSA(LRSB)
+33 IF $PIECE(LRSB(LRSB),"^")'=""
SET ^LR(LRDFN,LRSS,LRIDT,LRSB)=LRSB(LRSB)
+34 IF $DATA(LRSA(LRSB,1))
IF $DATA(LRSA(LRSB,2))
DO DIDLE
End DoDot:1
+35 ;
+36 WRITE !!
+37 QUIT
+38 ;
+39 ;
DIDLE ;
+1 ; Check if no previous result or pending result - no audit trail needed
+2 IF $PIECE(LRSA(LRSB),"^")=""!($PIECE(LRSA(LRSB),"^")="pending")
QUIT
+3 ;
+4 SET LRF=1
+5 LOCK +^LR(LRDFN,LRSS,LRIDT):DILOCKTM+999
NOW ;
+1 NEW LRNOW7
+2 SET LRNOW7=$SELECT($GET(LRNOW):LRNOW,1:$$NOW^XLFDT)
+3 WRITE !
+4 DO ^LRDIDLE0
+5 IF 'LROK
KILL LRSA
+6 LOCK -^LR(LRDFN,LRSS,LRIDT)
+7 SET LRCORECT=1
+8 QUIT
+9 ;
+10 ;
RONLT ; (R)esolve (O)rder NLT code from file #68 original ordered test or
+1 ; use default when not specified for file #60 test.
+2 ;
+3 NEW LR60,LRX,LRY,X
+4 SET LR60=+LRTS
SET LRY=$PIECE(LRSB(LRSB),U,3)
+5 ;
+6 ; Try to determine order NLT from original ordered test
+7 FOR
if 'LR60
QUIT
Begin DoDot:1
+8 SET LRX=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LR60,0))
SET LR60=+$PIECE(LRX,"^",9)
+9 IF LR60
IF LR60'=$PIECE(LRX,"^")
Begin DoDot:2
+10 SET X=$$NLT^LRVER1(LR60)
+11 IF X'=""
SET $PIECE(LRY,"!")=X
End DoDot:2
+12 IF LR60=$PIECE(LRX,"^")
SET LR60=0
End DoDot:1
+13 ;
+14 ; Otherwise use default for lab package
+15 IF $PIECE(LRY,"!")=""
SET $PIECE(LRY,"!")=$PIECE($$DEFCODE^LA7VHLU5(LRSS,LRSB,LRY,+LRSPEC),"!")
+16 ;
+17 SET $PIECE(LRSB(LRSB),U,3)=LRY
+18 ;
+19 QUIT
+20 ;
+21 ;
LRORU3 ;
SET ;
+1 NEW LR64,LR7V,LRDN,LROTA,LRT,LRTPN,LRTPNN,LRTYPE,X
+2 ;
+3 ; Go through LRSB array and sort results by order NLT code
+4 ; and put into ordered test array (LROTA).
+5 SET LRDN=0
+6 FOR
SET LRDN=$ORDER(LRSB(LRDN))
if 'LRDN
QUIT
Begin DoDot:1
+7 IF $PIECE(LRSB(LRDN),"^")=""
QUIT
+8 SET LRTPNN=$PIECE($PIECE(LRSB(LRDN),U,3),"!")
SET LRT=+$GET(^TMP("LR",$JOB,"TMP",LRDN))
+9 IF LRTPNN=""
QUIT
+10 SET LRTYPE=$PIECE($GET(^LAB(60,LRT,0)),U,3)
+11 IF LRTYPE=""!("OB"'[LRTYPE)
QUIT
+12 SET LROTA(LRTPNN,LRDN)=LRT
+13 IF $DATA(LRSA(LRDN,2))
SET LROTA(LRTPNN,LRDN,1)="C"
End DoDot:1
+14 ;
+15 ; For each order NLT code setup call to put results into #62.49 queue
+16 SET LRTPNN=""
+17 FOR
SET LRTPNN=$ORDER(LROTA(LRTPNN))
if LRTPNN=""
QUIT
Begin DoDot:1
+18 SET LR64=+$ORDER(^LAM("C",LRTPNN_" ",0))
SET LRTPN=$$GET1^DIQ(64,LR64_",",.01)
+19 KILL LR7V
+20 MERGE LR7V=LROTA(LRTPNN)
+21 DO SET^LA7VMSG($PIECE(LRORU3,U,4),$PIECE(LRORU3,U,2),$PIECE(LRORU3,U,5),$PIECE(LRORU3,U,3),LRTPN,LRTPNN,LRIDT,LRSS,LRDFN,LRODT,.LR7V,"ORU")
End DoDot:1
+22 QUIT
+23 ;
+24 ;
ASKXQA ; Determine if user should be asked to send CPRS Alert
+1 ;
+2 NEW LRDEFAULT
+3 ;
+4 ; No CPRS alert for non-PATIENT file (#2) patients
+5 IF +LRDPF'=2
QUIT
+6 ;
+7 SET LRDEFAULT=$$GET^XPAR("USR^DIV^PKG","LR CH VERIFY CPRS ALERT",1,"Q")
+8 IF LRDEFAULT>0
DO ASKXQA^LR7ORB3(LRDFN,"CH",LRIDT,LRUID,LRDEFAULT)
+9 ;
+10 QUIT
