LRVER3 ;DALOI/CJS/JAH - DATA VERIFICATION ; 03-Oct-2016 10:28 ; MKK
;;5.2;LAB SERVICE;**42,100,121,140,171,1010,153,1018,286,1027,291,1031,406,1033,1038,1039**;NOV 1, 1997;Build 38
;
; NOTE: LR*5.2*1031 restores LR*5.2*1027 modifications
;
EP ; EP - LR*5.2*1031
D V1
I $D(LRLOCKER)#2 L -@(LRLOCKER) K LRLOCKER
Q
;
;
V1 I $D(LRLOCKER)#2 L -@(LRLOCKER)
S LRLOCKER="^LR("_LRDFN_","""_LRSS_""","_LRIDT_")"
L +@(LRLOCKER):1
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 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" 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")
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
. Q:LRSB=9009027 ; IHS/OIT/MKK LR*5.2*1027 - Skip E-SIG ENTRY
. Q:$G(^(LRSB))="" ; IHS/MSC/MKK - LR*5.2*1033 - Skip "empty" node
. 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
; I '$G(LRCHG),'LRVF F LRSB=1:0 S LRSB=$O(LRSB(LRSB)) Q:LRSB<1 S:LRSB(LRSB)'="" ^LR(LRDFN,LRSS,LRIDT,LRSB)=LRSB(LRSB)
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039 - Add in LEDI IV update to put Result Date into File 63
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)
; ----- END IHS/MSC/MKK - LR*5.2*1039 - Add in LEDI IV update
;
I $G(LRCHG) D CHG K LRCHG,LRUP I $G(LREND) S LREND=0 G EXIT
;
I $D(LRSA),$D(LRF) K LRF S X=$P(^LR(LRDFN,LRSS,LRIDT,0),U,9) S:$L(X)&($E(X)'["-") $P(^(0),U,9)="-"_X G V11
G EXIT:$D(LRGVP),V11:LRVF&$D(LRSA),V1:LRVF&(LRNTN>1),EXIT:LRVF
;
NOVER I $O(LRNOVER(0)) D G EXIT
. F I=0:0 S I=+$O(LRNOVER(I)) Q:I<2 W !,"Test Not Reviewed: ",$P(^DD(63.04,I,0),U) W:$D(LRSB(I))#2 " = "_$P(LRSB(I),U)_" "_$P(LRSB(I),U,2)
. W !,$$CJ^XLFSTR("The above test(s) have results already entered,",80)
. W !,$$CJ^XLFSTR("but you did not select them for review.",80)
. W !,$$CJ^XLFSTR(" Accession NOT approved. ",80),$C(7)
. W !,$$CJ^XLFSTR("You must review all results before ANY can be released.",80),!!
. W:$E(IOST,1,2)="C-" @LRVIDO W $$CJ^XLFSTR("Suggest you select 'ALL' tests for verification/review. ",80) W:$E(IOST,1,2)="C-" @LRVIDOF W !,$C(7)
I $O(LRNOVER(0)) W !,"Has not been reviewed and has 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
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
S LRINI=$$GETINITS("Approve for release by entering your initials: ")
; ----- END IHS/MSC/MKK - LR*5.2*1038
;
; I $E(LRINI)="^" W !!?5,$C(7),"Nothing verified!" D READ G EXIT
;
;----- BEGIN IHS/OIT/MKK LR*5.2*1027 -- Pause 2 seconds to allow user to see the message
I $E(LRINI)="^" W !!?5,$C(7),"*** Nothing verified! ***" W *7,! H 2 D READ G EXIT
;----- END IHS/OIT/MKK LR*5.2*1027
;
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
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
S LRUP=""
S LRNOW=$$NOW^XLFDT ; IHS/MSC/MKK - LR*5.2*1039 - LEDI IV
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") S LRSA(LRCHG,3)=1,LRUP=1 Q
. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039 - LEDI IV - Update release time
. I $P(LRSA(LRCHG),"^")=""!($P(LRSA(LRCHG),"^")="pending") D Q
. . S LRSA(LRCHG,3)=1
. . S LRUP=1
. . S $P(LRSB(LRCHG),U,6)=LRNOW
. ; ----- END IHS/MSC/MKK - LR*5.2*1039
. 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)) S $P(LRSB(LRCHG),U,6)=LRNOW ; IHS/MSC/MKK - LR*5.2*1039 - LEDI IV - Update user/release time
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
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
S LRINI=$$GETINITS("")
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
;
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)
. 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):999
NOW S LRNOW7=$$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)
Q
;
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
GETINITS(PROMPT) ; EP - Get Initials. Mask User input.
NEW ANSWER,STEP,TEXT
;
W:$L($G(PROMPT)) !,PROMPT
S ANSWER=""
; F STEP=1:1:4 R TEXT#1 S:TEXT="^" ANSWER="^" Q:TEXT="^"!(TEXT="") S ANSWER=ANSWER_TEXT W $C(8),"*"
F STEP=1:1:6 R TEXT#1 S:TEXT="^" ANSWER="^" Q:TEXT="^"!(TEXT="") S ANSWER=ANSWER_TEXT W $C(8),"*" ; IHS/MSC/MKK - LR*5.2*1039 - Initials can be 5 characters long
Q ANSWER
; ----- END IHS/MSC/MKK - LR*5.2*1038
LRVER3 ;DALOI/CJS/JAH - DATA VERIFICATION ; 03-Oct-2016 10:28 ; MKK
+1 ;;5.2;LAB SERVICE;**42,100,121,140,171,1010,153,1018,286,1027,291,1031,406,1033,1038,1039**;NOV 1, 1997;Build 38
+2 ;
+3 ; NOTE: LR*5.2*1031 restores LR*5.2*1027 modifications
+4 ;
EP ; EP - LR*5.2*1031
+1 DO V1
+2 IF $DATA(LRLOCKER)#2
LOCK -@(LRLOCKER)
KILL LRLOCKER
+3 QUIT
+4 ;
+5 ;
V1 IF $DATA(LRLOCKER)#2
LOCK -@(LRLOCKER)
+1 SET LRLOCKER="^LR("_LRDFN_","""_LRSS_""","_LRIDT_")"
+2 LOCK +@(LRLOCKER):1
+3 IF '$TEST
WRITE !," This entry is being edited by someone else."
QUIT
+4 IF $DATA(LRGVP)
SET X="1-"_LRNTN
DO RANGE^LRWU2
GOTO L10
+5 SET LRALL=""
SET LRALERT=LROUTINE
SET LRLCT=6
+6 ;
+7 ; List any not performed tests.
+8 SET I=0
+9 FOR
SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I))
IF I<1
QUIT
Begin DoDot:1
+10 SET LRX=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I,0))
+11 IF $PIECE(LRX,"^",6)'="*Not Performed"
QUIT
+12 WRITE !,?3,$PIECE(^LAB(60,I,0),"^"),?25," ",$PIECE(LRX,"^",6)
+13 SET LRLCT=LRLCT+1
IF LRLCT>22
DO WT^LRVER4
End DoDot:1
+14 ;
+15 ; No tests to edit
+16 IF LRNTN=0
DO COM^LRVR4
GOTO EXIT
+17 ;
+18 FOR I=1:1:LRNTN
IF $DATA(LRNAME(I))
Begin DoDot:1
+19 SET LRALL=LRALL_","_I
WRITE !,I," ",LRNAME(I)
+20 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,$ORDER(LRNAME(I,0)),0))#2
Begin DoDot:2
+21 SET LRX=^LRO(68,LRAA,1,LRAD,1,LRAN,4,$ORDER(LRNAME(I,0)),0)
+22 SET LRAL=$PIECE(LRX,U,2)#50
+23 IF $PIECE(LRX,U,5)
WRITE ?25,$SELECT($PIECE(LRX,U,6)'="":$PIECE(LRX,U,6),1:" verified")
+24 IF LRAL
SET LRALERT=$SELECT(LRAL<LRALERT:LRAL,1:LRALERT)
End DoDot:2
+25 SET LRLCT=LRLCT+1
IF LRLCT>22
DO WT^LRVER4
End DoDot:1
+26 ;
+27 IF $DATA(LRALERT)
IF LRALERT<($PIECE(LRPARAM,U,20)+1)
Begin DoDot:1
+28 WRITE !?15
IF IOST["C-"
WRITE @LRVIDO
+29 WRITE "Test ordered "_$PIECE($GET(^LAB(62.05,+LRALERT,0)),U)
+30 IF IOST["C-"
WRITE @LRVIDOF
WRITE !,$CHAR(7)
End DoDot:1
+31 ;
+32 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
L10 ;
+1 NEW LRCORECT
SET LRCORECT=0
+2 SET LRNX=0
XECUTE (X9_"D EX1^LRVER1")
+3 DO V7^LRVER2
+4 SET LRCMTDSP=$$CHKCDSP^LRVERA
+5 KILL LRSA,LRSB,LRORU3
+6 FOR LRSB=1:0
SET LRSB=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRSB))
IF LRSB<1
QUIT
Begin DoDot:1
+7 ; IHS/OIT/MKK LR*5.2*1027 - Skip E-SIG ENTRY
IF LRSB=9009027
QUIT
+8 ; IHS/MSC/MKK - LR*5.2*1033 - Skip "empty" node
IF $GET(^(LRSB))=""
QUIT
+9 SET LRSB(LRSB)=^(LRSB)
SET LRSB(LRSB,"P")=$PIECE(LRSB(LRSB),U,3)
+10 IF $DATA(LRNOVER)
SET LRNOVER(LRSB)=""
End DoDot:1
+11 SET LREDIT=1
+12 DO ^LRVER4
+13 ;
+14 ; If group data review then quit before updating results
+15 IF $DATA(LRGVP)
GOTO EXIT
+16 ;
+17 IF '$ORDER(LRORD(0))
GOTO EXIT
+18 ; I '$G(LRCHG),'LRVF F LRSB=1:0 S LRSB=$O(LRSB(LRSB)) Q:LRSB<1 S:LRSB(LRSB)'="" ^LR(LRDFN,LRSS,LRIDT,LRSB)=LRSB(LRSB)
+19 ;
+20 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039 - Add in LEDI IV update to put Result Date into File 63
+21 IF '$GET(LRCHG)
IF 'LRVF
Begin DoDot:1
+22 NEW LRNOW
SET LRNOW=$$NOW^XLFDT
+23 FOR LRSB=1:0
SET LRSB=$ORDER(LRSB(LRSB))
IF LRSB<1
QUIT
IF $PIECE(LRSB(LRSB),"^")'=""
Begin DoDot:2
+24 SET $PIECE(LRSB(LRSB),U,6)=LRNOW
+25 SET ^LR(LRDFN,LRSS,LRIDT,LRSB)=LRSB(LRSB)
End DoDot:2
End DoDot:1
+26 ; ----- END IHS/MSC/MKK - LR*5.2*1039 - Add in LEDI IV update
+27 ;
+28 IF $GET(LRCHG)
DO CHG
KILL LRCHG,LRUP
IF $GET(LREND)
SET LREND=0
GOTO EXIT
+29 ;
+30 IF $DATA(LRSA)
IF $DATA(LRF)
KILL LRF
SET X=$PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,9)
IF $LENGTH(X)&($EXTRACT(X)'["-")
SET $PIECE(^(0),U,9)="-"_X
GOTO V11
+31 IF $DATA(LRGVP)
GOTO EXIT
IF LRVF&$DATA(LRSA)
GOTO V11
IF LRVF&(LRNTN>1)
GOTO V1
IF LRVF
GOTO EXIT
+32 ;
NOVER IF $ORDER(LRNOVER(0))
Begin DoDot:1
+1 FOR I=0:0
SET I=+$ORDER(LRNOVER(I))
IF I<2
QUIT
WRITE !,"Test Not Reviewed: ",$PIECE(^DD(63.04,I,0),U)
IF $DATA(LRSB(I))#2
WRITE " = "_$PIECE(LRSB(I),U)_" "_$PIECE(LRSB(I),U,2)
+2 WRITE !,$$CJ^XLFSTR("The above test(s) have results already entered,",80)
+3 WRITE !,$$CJ^XLFSTR("but you did not select them for review.",80)
+4 WRITE !,$$CJ^XLFSTR(" Accession NOT approved. ",80),$CHAR(7)
+5 WRITE !,$$CJ^XLFSTR("You must review all results before ANY can be released.",80),!!
+6 IF $EXTRACT(IOST,1,2)="C-"
WRITE @LRVIDO
WRITE $$CJ^XLFSTR("Suggest you select 'ALL' tests for verification/review. ",80)
IF $EXTRACT(IOST,1,2)="C-"
WRITE @LRVIDOF
WRITE !,$CHAR(7)
End DoDot:1
GOTO EXIT
+7 IF $ORDER(LRNOVER(0))
WRITE !,"Has not been reviewed and has data. Not approved.",!
GOTO EXIT
+8 IF '$PIECE($GET(LRLABKY),U)
WRITE !,$CHAR(7),"ENTERED BUT NOT APPROVED",!
GOTO EXIT
+9 IF '$ORDER(LRSB(0))
WRITE !?5,"Nothing verified ",$CHAR(7),!
GOTO EXIT
+10 NEW CNT
SET CNT=1
AGAIN ;
+1 ; R !,"Approve for release by entering your initials: ",LRINI:DTIME
+2 ;
+3 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
+4 SET LRINI=$$GETINITS("Approve for release by entering your initials: ")
+5 ; ----- END IHS/MSC/MKK - LR*5.2*1038
+6 ;
+7 ; I $E(LRINI)="^" W !!?5,$C(7),"Nothing verified!" D READ G EXIT
+8 ;
+9 ;----- BEGIN IHS/OIT/MKK LR*5.2*1027 -- Pause 2 seconds to allow user to see the message
+10 IF $EXTRACT(LRINI)="^"
WRITE !!?5,$CHAR(7),"*** Nothing verified! ***"
WRITE *7,!
HANG 2
DO READ
GOTO EXIT
+11 ;----- END IHS/OIT/MKK LR*5.2*1027
+12 ;
+13 IF LRINI'=LRUSI
IF $$UP^XLFSTR(LRINI)=$$UP^XLFSTR(LRUSI)
SET LRINI=LRUSI
+14 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
+15 IF LRINI'=LRUSI
WRITE !!?5,$CHAR(7),"Nothing verified!"
DO READ
GOTO EXIT
V11 ; START RESPONSE TIME LOGGING
IF $DATA(XRTL)
DO T0^%ZOSV
+1 IF +LRDPF=2&($GET(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT))
Begin DoDot:1
+2 DO BAWRK^LRBEBA(LRODT,LRSN,1,.LRBEY,.LRTEST)
End DoDot:1
+3 DO VER^LRVER3A
+4 IF $PIECE(LRPARAM,U,14)
IF $PIECE($GET(^LRO(68,LRAA,0)),U,16)
DO LOOK^LRCAPV1
+5 NEW LRX
+6 SET LRX=0
+7 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)=""
+8 IF $PIECE($GET(LRORU3),U,3)
IF $ORDER(LRSB(0))
DO LRORU3
+9 ; STOP RESPONSE TIME LOGGING
IF $DATA(XRT0)
SET XRTN="V11^LRVER3"
DO T1^%ZOSV
+10 SET LRVF=1
+11 QUIT
+12 ;
+13 ;
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 SET LRUP=""
+2 ; IHS/MSC/MKK - LR*5.2*1039 - LEDI IV
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 ; I $P(LRSA(LRCHG),"^")=""!($P(LRSA(LRCHG),"^")="pending") S LRSA(LRCHG,3)=1,LRUP=1 Q
+6 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039 - LEDI IV - Update release time
+7 IF $PIECE(LRSA(LRCHG),"^")=""!($PIECE(LRSA(LRCHG),"^")="pending")
Begin DoDot:2
+8 SET LRSA(LRCHG,3)=1
+9 SET LRUP=1
+10 SET $PIECE(LRSB(LRCHG),U,6)=LRNOW
End DoDot:2
QUIT
+11 ; ----- END IHS/MSC/MKK - LR*5.2*1039
+12 ; results changed
IF $PIECE(LRSA(LRCHG),"^")'=$PIECE(LRSB(LRCHG),"^")
SET LRUP=1
SET $PIECE(LRSA(LRCHG,2),"^")=1
+13 ; normalcy flag changed
IF $PIECE(LRSA(LRCHG),"^",2)'=$PIECE(LRSB(LRCHG),"^",2)
SET LRUP=1
SET $PIECE(LRSA(LRCHG,2),"^",2)=1
+14 ; units/normals changed
IF $PIECE(LRSA(LRCHG),"^",5)'=$PIECE(LRSB(LRCHG),"^",5)
Begin DoDot:2
+15 NEW LRX,LRY
+16 SET LRX=$$UP^XLFSTR($PIECE(LRSA(LRCHG),"^",5))
SET LRX=$TRANSLATE(LRX,"""")
+17 SET LRY=$$UP^XLFSTR($PIECE(LRSB(LRCHG),"^",5))
SET LRY=$TRANSLATE(LRY,"""")
+18 IF LRX'=LRY
SET LRUP=1
SET $PIECE(LRSA(LRCHG,2),"^",5)=1
End DoDot:2
+19 ; IHS/MSC/MKK - LR*5.2*1039 - LEDI IV - Update user/release time
IF $DATA(LRSA(LRCHG,2))
SET $PIECE(LRSB(LRCHG),U,6)=LRNOW
End DoDot:1
+20 IF 'LRUP
SET LREND=1
QUIT
+21 SET LREND=0
+22 WRITE !!
IF IOST["C-"
WRITE @LRVIDO
WRITE "Approve update of data by entering your initials: "
IF IOST["C-"
WRITE @LRVIDOF
+23 ;
+24 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
+25 SET LRINI=$$GETINITS("")
+26 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
+27 ;
+28 IF 'LREND
IF LRINI'=LRUSI
IF $$UP^XLFSTR(LRINI)=$$UP^XLFSTR(LRUSI)
SET LRINI=LRUSI
+29 IF LRINI'=LRUSI
SET LREND=1
+30 IF LREND
WRITE !,$CHAR(7),"No updating occurred ",!
QUIT
+31 ;
+32 FOR LRSB=1:0
SET LRSB=$ORDER(LRSB(LRSB))
IF LRSB<1
QUIT
Begin DoDot:1
+33 IF '$DATA(^LR(LRDFN,LRSS,LRIDT,LRSB))
KILL LRSA(LRSB)
+34 SET ^LR(LRDFN,LRSS,LRIDT,LRSB)=LRSB(LRSB)
+35 IF $DATA(LRSA(LRSB,1))
IF $DATA(LRSA(LRSB,2))
DO DIDLE
End DoDot:1
+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):999
NOW SET LRNOW7=$$NOW^XLFDT
+1 WRITE !
+2 DO ^LRDIDLE0
+3 IF 'LROK
KILL LRSA
+4 LOCK -^LR(LRDFN,LRSS,LRIDT)
+5 SET LRCORECT=1
+6 QUIT
+7 ;
+8 ;
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)
End DoDot:1
+22 QUIT
+23 ;
+24 ;
+25 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
GETINITS(PROMPT) ; EP - Get Initials. Mask User input.
+1 NEW ANSWER,STEP,TEXT
+2 ;
+3 IF $LENGTH($GET(PROMPT))
WRITE !,PROMPT
+4 SET ANSWER=""
+5 ; F STEP=1:1:4 R TEXT#1 S:TEXT="^" ANSWER="^" Q:TEXT="^"!(TEXT="") S ANSWER=ANSWER_TEXT W $C(8),"*"
+6 ; IHS/MSC/MKK - LR*5.2*1039 - Initials can be 5 characters long
FOR STEP=1:1:6
READ TEXT#1
IF TEXT="^"
SET ANSWER="^"
IF TEXT="^"!(TEXT="")
QUIT
SET ANSWER=ANSWER_TEXT
WRITE $CHAR(8),"*"
+7 QUIT ANSWER
+8 ; ----- END IHS/MSC/MKK - LR*5.2*1038
