- 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 Feb 18, 2025@23:48:23 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