LRVR1 ;DALOI/CJS/JAH - LAB ROUTINE DATA VERIFICATION;Sep 27, 2018@10:00:00
;;5.2;LAB SERVICE;**42,153,221,286,291,350,424,440,512,524**;Sep 27, 1994;Build 14
;
N LRBETST,LRBEY,LRI,LRN,LRPRGSQ
S (LRI,LRN)=0
F S LRI=$O(^LAH(LRLL,1,"C",LRAN,LRI)) Q:LRI<1 D
. N LRX
. S LRX=$G(^LAH(LRLL,1,LRI,0))
. ; Quit if different accession area.
. I $P(LRX,"^",3),$P(LRX,"^",3)'=LRAA Q
. ; Quit if different accession date and not a rollover accession (same original accession date).
. I $P(LRX,"^",4),$P(LRX,"^",4)'=LRAD,$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",3)'=$P($G(^LRO(68,LRAA,1,$P(LRX,"^",4),1,LRAN,0)),"^",3) Q
. I LRN W !
. S LRN=LRN+1,LRSQ=LRI,LRPRGSQ(LRI)=""
. W !,?2,"Seq #: ",LRI,?13," Accession: ",$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^")
. I $P(LRX,"^",10) W ?40," Results received: ",$$FMTE^XLFDT($P(LRX,"^",10),"1M")
. W !,?20,"UID: ",$P($G(^LAH(LRLL,1,LRI,.3),"UNKNOWN"),"^")
. I $P(LRX,"^",11) W ?44," Last updated: ",$$FMTE^XLFDT($P(LRX,"^",11),"1M")
;
; If multiple sets of results then query user if they want to display a specific sequence
I LRN>1 D
. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,X,Y
. S DIR(0)="SO^0:Skip Display"
. S I=0 F S I=$O(LRPRGSQ(I)) Q:'I S DIR(0)=DIR(0)_";"_I_":Seq # "_I
. S DIR("A")="Display results associated with sequence #",DIR("B")="Skip Display"
. D ^DIR
. I Y<1 W ! Q
. D SEQDISP(LRLL,Y)
;
G VER:LRN=1,T3:LRN>1
;
; If attempting to verify reference lab results and no entry in LAH
; associated with this accession then quit - do not allow manual entry
; of ref lab results via this option. Will not store units/normals.
I $G(LRDUZ(2)),DUZ(2)'=LRDUZ(2) W !,"No data there" Q
;
T1 R !,"What tray: ",X:DTIME Q:X["^"!'$T I X["?"!(X'?.N) W !,"Enter a number" G T1
I X'="" S LRTRAY=X G T2
I $D(^LRO(68.2,"AS",LRLL)) W !,"Can't MANUALLY add to a SEQUENCE instrument data file." G QUIT
W !,"Enter manually" S %=1 D YN^DICN G QUIT:%<1,T1:%=2 S LRSQ=-1 G VER
G VER
;
T2 R !,"What cup: ",X:DTIME Q:X["^"!'$T I X["?"!(X'?.N) W !,"Enter a number" G T2
Q:X=""
S LRTRCP=LRTRAY_";"_X I $L(LRTRCP)>200 S LRN=0 G T3 ;*424 - Do not allow string over 200
K LRPRGSQ
S LRN=0
F LRI=0:0 S LRI=$O(^LAH(LRLL,1,"B",LRTRCP,LRI)) Q:LRI<1 S LRN=LRN+1,LRSQ=LRI,LRPRGSQ(LRI)="" W !,?5,LRI
;
T3 I LRN=0 W !,"No data for that tray & cup" Q
I LRN>1 R !,"Choose sequence number: ",X:DTIME Q:'$T I X["?"!(X'?.N) W !,"Enter a number" G T3
I X["^"!(X="") K LRPRGSQ Q
S:LRN'=1 LRSQ=X
I '$D(^LAH(LRLL,1,LRSQ,0)) W !,"No data there" G T3
;
VER ; from LRFLAG, LRGP, LRVRW
N LRROOT
K LRTEST,LRNM,^TMP("LR",$J,"TMP")
S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
;
; Determine if there are amended results to process via "EM"
S LRROOT=$Q(^LAH("LA7 AMENDED RESULTS",LRUID,1,LRLL))
I LRROOT'="",$QS(LRROOT,1)="LA7 AMENDED RESULTS",$QS(LRROOT,2)=LRUID,$QS(LRROOT,4)=LRLL D Q
. W !!,"Amended results exist for this accession. Please process these"
. W !,"first using option Enter/verify/modify data (manual) [LRENTER]"
;
D TEST
I $O(^TMP("LR",$J,"TMP",0))="" W !,"No tests in editing profile" Q
S X=DUZ D DUZ^LRX
G V2:LRSQ>0
;
L +^LAH(LRLL):DILOCKTM
I '$T Q
;
S (^LAH(LRLL),LRSQ)=1+$G(^LAH(LRLL))
S ^LAH(LRLL,1,LRSQ,0)="^^"_LRAA_"^"_LRAD_"^"_LRAN_"^^MANUAL"
D UID^LAGEN(LRLL,LRSQ,LRUID)
D UPDT^LAGEN(LRLL,LRSQ)
S ^LAH(LRLL,1,"C",LRAN,LRSQ)=""
L -^LAH(LRLL)
;
V2 K LRPRGSQ(LRSQ)
S LRLLOC=0,LROUTINE=$P(^LAB(69.9,1,3),U,2)
I $D(^LRO(69,LRODT,1,LRSN,0)) S LRLLOC=$P(^(0),U,7) S:'$L(LRLLOC) LRLLOC=0 W !,$P(^LRO(69,LRODT,1,LRSN,1),U,6)
S LRCDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U)
I '$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",3) D
. N %DT,LRA1,LRA2,LRA3
. S %DT("B")=$$FMTE^XLFDT(LRCDT,"1")
. S LRSTATUS="C",LRA1=LRAA,LRA2=LRAD,LRA3=LRAN
. D P15^LROE1
. S LRAA=LRA1,LRAD=LRA2,LRAN=LRA3
. I LRCDT<1 Q
. I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,3) S $P(^(3),U,3)=$$NOW^XLFDT
; If user did not update then go to next
I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,3) Q
S LRCDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U)
I LRCDT<1 Q
S LREAL=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,2),LRALERT=LROUTINE
S I=0
F S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5 I $G(^(I,0)) S LRAL=$P($G(^(0)),U,2) D
. I $G(LRAL) S LRALERT=$S(LRAL<50&(LRAL<LRALERT):LRAL,LRAL>50&(LRAL-50<LRALERT):LRAL-50,1:LRALERT)
S LRSAMP=$P($G(^LRO(69,LRODT,1,LRSN,0)),U,3)
;
S LRSS=$P(^LRO(68,LRAA,0),U,2)
I LRSS'="CH" Q
; Check for valid pointer to file #63 and entry in file #63.
S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
I LRIDT<1 W !,">>>>ERROR - NO POINTER TO FILE #63 - PLEASE NOTIFY SYSTEM MANAGER^ <<<<<",! Q
I '$D(^LR(LRDFN,LRSS,LRIDT,0)) W !,">>>>ERROR - NO ENTRY IN FILE #63 - PLEASE NOTIFY SYSTEM MANAGER<<^ <<<",! Q
;
S LRCW=8
LD S LRSS="CH"
;
; If bad entry then cleanup as best as possible.
I '($D(^LAH(LRLL,1,LRSQ,0))#2) D Q
. W !!?5,"No Data for this Accession ",!!
. D ZAPALL^LRVR3(LRLL,LRSQ)
. K LRPRGSQ
;
; Store any new methods with existing methods on file.
S LRMETH=$P(^LAH(LRLL,1,LRSQ,0),U,7) S:$D(LRGVP) LRMETH=LRMETH_"(GV)"
I $P($G(^LR(LRDFN,LRSS,LRIDT,0)),U,8)'="" D
. N I,X
. S X=$P(^LR(LRDFN,LRSS,LRIDT,0),U,8)
. F I=1:1:$L(X,";") I $P(X,";",I)'="",LRMETH'[$P(X,";",I) S LRMETH=LRMETH_";"_$P(X,";",I)
I LRMETH'="" S $P(^LR(LRDFN,LRSS,LRIDT,0),U,8)=LRMETH
;
S LRTM60=$$LRTM60^LRVR(LRCDT)
;
W:$D(^LAB(62,+LRSAMP,0)) !,"Sample: ",$P(^(0),U)
;
D ^LRVR2
K LRDL,LRPRGSQ
Q ; leave LRVR1, back to LRVR
;
;
TEST ; from LRGV1
N LRI,LRX
S LRI=0
F S LRI=$O(^TMP("LR",$J,"VTO",LRI)) Q:LRI<1 K ^(LRI,"P")
S (LRI,LRNT)=0
F S LRI=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI)) Q:LRI<.5 I $D(^(LRI,0)),'$L($P(^(0),U,6)) S X=^(0) I $D(^TMP("LR",$J,"VTO",+X)) D
. ;LR*5.2*512: modified line below to always set the panel as the parent test
. ;line was formerly:
. ; . S LRNT=LRNT+1,LRTEST(LRNT)=+X,LRX=$S($P(X,"^",2)>50:$P(X,"^",9),1:$P(X,"^"))
. ;The line above may have been coded based on the urgency field in LR*5.2*291
. ;which was released in 2006 but the functionality regarding bundling/unbundling
. ;was not implemented.
. S LRNT=LRNT+1,LRTEST(LRNT)=+X,LRX=$P(X,"^",9)
. I $P(X,"^",9),$P(X,"^")'=$P(X,"^",9),'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,$P(X,"^",9))) S LRX=$P(X,"^",9)
. S LRTEST(LRNT,"P")=LRX_U_$$NLT^LRVER1(LRX)_"!"
. S ^TMP("LR",$J,"VTO",+X,"P")=$P(LRTEST(LRNT,"P"),"!")
;
TEST1 ; from LRFLAG
;
N LRI
F LRI=1:1:LRNT S:$D(^LAB(60,+LRTEST(LRI),0)) (LRTEST(LRI),LRBETST(LRI))=LRTEST(LRI)_U_^(0)
I $G(LRORDR)'="P" K ^TMP("LR",$J,"TMP")
S LRNX=0
K LRM
F I=1:1 Q:'$D(LRTEST(I)) D
. S X=LRTEST(I),XP=$G(LRTEST(I,"P"))
. K LRTEST(I)
. D EX2
K LRTEST
Q
;
;
EX2 ;
; If dataname then process and quit
S LRSUB=$P(X,U,6)
I LRSUB'="" D Q
. S LRSB=$P(LRSUB,";",2)
. Q:'$D(LRVTS(LRSB))
. I $D(^TMP("LR",$J,"TMP",LRSB)) S ^(LRSB,"P")=XP
. S ^TMP("LR",$J,"TMP",LRSB)=+X
. S XP=XP_$$RNLT^LRVER1(+X)
. S ^TMP("LR",$J,"TMP",LRSB,"P")=XP
. S:$P(X,U,18) LRM(LRSB)=+X,LRM(LRSB,"P")=XP
. S LRBEY(+X,LRSB)="" ; CIDC
;
I $D(^LAB(60,+X,4)),$P(^(4),"^",2) S LRCFL=LRCFL_$P(^(4),"^",2)_U
;
; If panel then explode components of panel and
; set parent("P" node) to file #60 test being exploded
S J=0
F S J=$O(^LAB(60,+X,2,J)) Q:J<1 I $D(^(J,0))#2 D
. S Y=^LAB(60,+X,2,J,0)
. ;quit if merged or not performed - LR*5.2*524
. Q:$L($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+Y,0)),U,6))
. S LRNT=LRNT+1
. S LRTEST(LRNT)=+Y_U_^LAB(60,+Y,0)
. S LRTEST(LRNT,"P")=+XP_U_$$NLT^LRVER1(+XP)_"!"
Q
;
;
QUIT Q
;
;
WAIT W !,"Type ""^"" to skip "
WAIT1 R X:10
G LRVR1:X[U,WAIT1:$O(^LAH(LRLL,1,"C",LRAN,0))<1
G LRVR1
;
;
SEQDISP(LRLL,LRISQN) ; Display test results for a LAH entry.
; Call with LRLL = ien of enry in LAH
; LRISQN = sequence ien of enry in LAH
;
N LR60,LRI,LRJ,LRSB,LRX,LRY
;
W !!,"Results for Sequence #"_LRISQN
;
I $O(^LAH(LRLL,1,LRISQN,1)) D
. W !,"Test",?25,"Value",?40,"Flag",?50,"Units"
. W !,"----",?25,"-----",?40,"----",?50,"-----"
;
; Display CH subsript results.
S LRSB=1
F S LRSB=$O(^LAH(LRLL,1,LRISQN,LRSB)) Q:LRSB<1 D
. S LRX=^LAH(LRLL,1,LRISQN,LRSB)
. S LR60=+$O(^LAB(60,"C","CH;"_LRSB_";1",0))
. S LR60(0)=$G(^LAB(60,LR60,0))
. W !,$E($P(LR60(0),"^"),1,24),?25," ",$P(LRX,"^"),?39," ",$P(LRX,"^",2),?49," ",$P($P(LRX,"^",5),"!",7)
;
; Display comments
I $D(^LAH(LRLL,1,LRISQN,1)) D
. W !,"Comments"
. S (LRI,LRY)=0,LRJ=""
. F S LRY=$O(^LAH(LRLL,1,LRISQN,1,LRY)) Q:LRY<1 D
. . S LRX=^LAH(LRLL,1,LRISQN,1,LRY),LRI=LRI+1
. . W !,"#",LRI," ",$P(LRX,"^")
. . I $P(LRX,"^",2) S LRJ=LRJ_$S(LRJ'="":",",1:"")_LRJ
. W !,"Comments # ",LRJ," previously processed"
;
W !
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVR1 8807 printed Jan 18, 2025@03:23:20 Page 2
LRVR1 ;DALOI/CJS/JAH - LAB ROUTINE DATA VERIFICATION;Sep 27, 2018@10:00:00
+1 ;;5.2;LAB SERVICE;**42,153,221,286,291,350,424,440,512,524**;Sep 27, 1994;Build 14
+2 ;
+3 NEW LRBETST,LRBEY,LRI,LRN,LRPRGSQ
+4 SET (LRI,LRN)=0
+5 FOR
SET LRI=$ORDER(^LAH(LRLL,1,"C",LRAN,LRI))
if LRI<1
QUIT
Begin DoDot:1
+6 NEW LRX
+7 SET LRX=$GET(^LAH(LRLL,1,LRI,0))
+8 ; Quit if different accession area.
+9 IF $PIECE(LRX,"^",3)
IF $PIECE(LRX,"^",3)'=LRAA
QUIT
+10 ; Quit if different accession date and not a rollover accession (same original accession date).
+11 IF $PIECE(LRX,"^",4)
IF $PIECE(LRX,"^",4)'=LRAD
IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",3)'=$PIECE($GET(^LRO(68,LRAA,1,$PIECE(LRX,"^",4),1,LRAN,0)),"^",3)
QUIT
+12 IF LRN
WRITE !
+13 SET LRN=LRN+1
SET LRSQ=LRI
SET LRPRGSQ(LRI)=""
+14 WRITE !,?2,"Seq #: ",LRI,?13," Accession: ",$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^")
+15 IF $PIECE(LRX,"^",10)
WRITE ?40," Results received: ",$$FMTE^XLFDT($PIECE(LRX,"^",10),"1M")
+16 WRITE !,?20,"UID: ",$PIECE($GET(^LAH(LRLL,1,LRI,.3),"UNKNOWN"),"^")
+17 IF $PIECE(LRX,"^",11)
WRITE ?44," Last updated: ",$$FMTE^XLFDT($PIECE(LRX,"^",11),"1M")
End DoDot:1
+18 ;
+19 ; If multiple sets of results then query user if they want to display a specific sequence
+20 IF LRN>1
Begin DoDot:1
+21 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,X,Y
+22 SET DIR(0)="SO^0:Skip Display"
+23 SET I=0
FOR
SET I=$ORDER(LRPRGSQ(I))
if 'I
QUIT
SET DIR(0)=DIR(0)_";"_I_":Seq # "_I
+24 SET DIR("A")="Display results associated with sequence #"
SET DIR("B")="Skip Display"
+25 DO ^DIR
+26 IF Y<1
WRITE !
QUIT
+27 DO SEQDISP(LRLL,Y)
End DoDot:1
+28 ;
+29 if LRN=1
GOTO VER
if LRN>1
GOTO T3
+30 ;
+31 ; If attempting to verify reference lab results and no entry in LAH
+32 ; associated with this accession then quit - do not allow manual entry
+33 ; of ref lab results via this option. Will not store units/normals.
+34 IF $GET(LRDUZ(2))
IF DUZ(2)'=LRDUZ(2)
WRITE !,"No data there"
QUIT
+35 ;
T1 READ !,"What tray: ",X:DTIME
if X["^"!'$TEST
QUIT
IF X["?"!(X'?.N)
WRITE !,"Enter a number"
GOTO T1
+1 IF X'=""
SET LRTRAY=X
GOTO T2
+2 IF $DATA(^LRO(68.2,"AS",LRLL))
WRITE !,"Can't MANUALLY add to a SEQUENCE instrument data file."
GOTO QUIT
+3 WRITE !,"Enter manually"
SET %=1
DO YN^DICN
if %<1
GOTO QUIT
if %=2
GOTO T1
SET LRSQ=-1
GOTO VER
+4 GOTO VER
+5 ;
T2 READ !,"What cup: ",X:DTIME
if X["^"!'$TEST
QUIT
IF X["?"!(X'?.N)
WRITE !,"Enter a number"
GOTO T2
+1 if X=""
QUIT
+2 ;*424 - Do not allow string over 200
SET LRTRCP=LRTRAY_";"_X
IF $LENGTH(LRTRCP)>200
SET LRN=0
GOTO T3
+3 KILL LRPRGSQ
+4 SET LRN=0
+5 FOR LRI=0:0
SET LRI=$ORDER(^LAH(LRLL,1,"B",LRTRCP,LRI))
if LRI<1
QUIT
SET LRN=LRN+1
SET LRSQ=LRI
SET LRPRGSQ(LRI)=""
WRITE !,?5,LRI
+6 ;
T3 IF LRN=0
WRITE !,"No data for that tray & cup"
QUIT
+1 IF LRN>1
READ !,"Choose sequence number: ",X:DTIME
if '$TEST
QUIT
IF X["?"!(X'?.N)
WRITE !,"Enter a number"
GOTO T3
+2 IF X["^"!(X="")
KILL LRPRGSQ
QUIT
+3 if LRN'=1
SET LRSQ=X
+4 IF '$DATA(^LAH(LRLL,1,LRSQ,0))
WRITE !,"No data there"
GOTO T3
+5 ;
VER ; from LRFLAG, LRGP, LRVRW
+1 NEW LRROOT
+2 KILL LRTEST,LRNM,^TMP("LR",$JOB,"TMP")
+3 SET LRUID=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
+4 ;
+5 ; Determine if there are amended results to process via "EM"
+6 SET LRROOT=$QUERY(^LAH("LA7 AMENDED RESULTS",LRUID,1,LRLL))
+7 IF LRROOT'=""
IF $QSUBSCRIPT(LRROOT,1)="LA7 AMENDED RESULTS"
IF $QSUBSCRIPT(LRROOT,2)=LRUID
IF $QSUBSCRIPT(LRROOT,4)=LRLL
Begin DoDot:1
+8 WRITE !!,"Amended results exist for this accession. Please process these"
+9 WRITE !,"first using option Enter/verify/modify data (manual) [LRENTER]"
End DoDot:1
QUIT
+10 ;
+11 DO TEST
+12 IF $ORDER(^TMP("LR",$JOB,"TMP",0))=""
WRITE !,"No tests in editing profile"
QUIT
+13 SET X=DUZ
DO DUZ^LRX
+14 if LRSQ>0
GOTO V2
+15 ;
+16 LOCK +^LAH(LRLL):DILOCKTM
+17 IF '$TEST
QUIT
+18 ;
+19 SET (^LAH(LRLL),LRSQ)=1+$GET(^LAH(LRLL))
+20 SET ^LAH(LRLL,1,LRSQ,0)="^^"_LRAA_"^"_LRAD_"^"_LRAN_"^^MANUAL"
+21 DO UID^LAGEN(LRLL,LRSQ,LRUID)
+22 DO UPDT^LAGEN(LRLL,LRSQ)
+23 SET ^LAH(LRLL,1,"C",LRAN,LRSQ)=""
+24 LOCK -^LAH(LRLL)
+25 ;
V2 KILL LRPRGSQ(LRSQ)
+1 SET LRLLOC=0
SET LROUTINE=$PIECE(^LAB(69.9,1,3),U,2)
+2 IF $DATA(^LRO(69,LRODT,1,LRSN,0))
SET LRLLOC=$PIECE(^(0),U,7)
if '$LENGTH(LRLLOC)
SET LRLLOC=0
WRITE !,$PIECE(^LRO(69,LRODT,1,LRSN,1),U,6)
+3 SET LRCDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U)
+4 IF '$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",3)
Begin DoDot:1
+5 NEW %DT,LRA1,LRA2,LRA3
+6 SET %DT("B")=$$FMTE^XLFDT(LRCDT,"1")
+7 SET LRSTATUS="C"
SET LRA1=LRAA
SET LRA2=LRAD
SET LRA3=LRAN
+8 DO P15^LROE1
+9 SET LRAA=LRA1
SET LRAD=LRA2
SET LRAN=LRA3
+10 IF LRCDT<1
QUIT
+11 IF '$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,3)
SET $PIECE(^(3),U,3)=$$NOW^XLFDT
End DoDot:1
+12 ; If user did not update then go to next
+13 IF '$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,3)
QUIT
+14 SET LRCDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U)
+15 IF LRCDT<1
QUIT
+16 SET LREAL=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,2)
SET LRALERT=LROUTINE
+17 SET I=0
+18 FOR
SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I))
if I<.5
QUIT
IF $GET(^(I,0))
SET LRAL=$PIECE($GET(^(0)),U,2)
Begin DoDot:1
+19 IF $GET(LRAL)
SET LRALERT=$SELECT(LRAL<50&(LRAL<LRALERT):LRAL,LRAL>50&(LRAL-50<LRALERT):LRAL-50,1:LRALERT)
End DoDot:1
+20 SET LRSAMP=$PIECE($GET(^LRO(69,LRODT,1,LRSN,0)),U,3)
+21 ;
+22 SET LRSS=$PIECE(^LRO(68,LRAA,0),U,2)
+23 IF LRSS'="CH"
QUIT
+24 ; Check for valid pointer to file #63 and entry in file #63.
+25 SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
+26 IF LRIDT<1
WRITE !,">>>>ERROR - NO POINTER TO FILE #63 - PLEASE NOTIFY SYSTEM MANAGER^ <<<<<",!
QUIT
+27 IF '$DATA(^LR(LRDFN,LRSS,LRIDT,0))
WRITE !,">>>>ERROR - NO ENTRY IN FILE #63 - PLEASE NOTIFY SYSTEM MANAGER<<^ <<<",!
QUIT
+28 ;
+29 SET LRCW=8
LD SET LRSS="CH"
+1 ;
+2 ; If bad entry then cleanup as best as possible.
+3 IF '($DATA(^LAH(LRLL,1,LRSQ,0))#2)
Begin DoDot:1
+4 WRITE !!?5,"No Data for this Accession ",!!
+5 DO ZAPALL^LRVR3(LRLL,LRSQ)
+6 KILL LRPRGSQ
End DoDot:1
QUIT
+7 ;
+8 ; Store any new methods with existing methods on file.
+9 SET LRMETH=$PIECE(^LAH(LRLL,1,LRSQ,0),U,7)
if $DATA(LRGVP)
SET LRMETH=LRMETH_"(GV)"
+10 IF $PIECE($GET(^LR(LRDFN,LRSS,LRIDT,0)),U,8)'=""
Begin DoDot:1
+11 NEW I,X
+12 SET X=$PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,8)
+13 FOR I=1:1:$LENGTH(X,";")
IF $PIECE(X,";",I)'=""
IF LRMETH'[$PIECE(X,";",I)
SET LRMETH=LRMETH_";"_$PIECE(X,";",I)
End DoDot:1
+14 IF LRMETH'=""
SET $PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,8)=LRMETH
+15 ;
+16 SET LRTM60=$$LRTM60^LRVR(LRCDT)
+17 ;
+18 if $DATA(^LAB(62,+LRSAMP,0))
WRITE !,"Sample: ",$PIECE(^(0),U)
+19 ;
+20 DO ^LRVR2
+21 KILL LRDL,LRPRGSQ
+22 ; leave LRVR1, back to LRVR
QUIT
+23 ;
+24 ;
TEST ; from LRGV1
+1 NEW LRI,LRX
+2 SET LRI=0
+3 FOR
SET LRI=$ORDER(^TMP("LR",$JOB,"VTO",LRI))
if LRI<1
QUIT
KILL ^(LRI,"P")
+4 SET (LRI,LRNT)=0
+5 FOR
SET LRI=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI))
if LRI<.5
QUIT
IF $DATA(^(LRI,0))
IF '$LENGTH($PIECE(^(0),U,6))
SET X=^(0)
IF $DATA(^TMP("LR",$JOB,"VTO",+X))
Begin DoDot:1
+6 ;LR*5.2*512: modified line below to always set the panel as the parent test
+7 ;line was formerly:
+8 ; . S LRNT=LRNT+1,LRTEST(LRNT)=+X,LRX=$S($P(X,"^",2)>50:$P(X,"^",9),1:$P(X,"^"))
+9 ;The line above may have been coded based on the urgency field in LR*5.2*291
+10 ;which was released in 2006 but the functionality regarding bundling/unbundling
+11 ;was not implemented.
+12 SET LRNT=LRNT+1
SET LRTEST(LRNT)=+X
SET LRX=$PIECE(X,"^",9)
+13 IF $PIECE(X,"^",9)
IF $PIECE(X,"^")'=$PIECE(X,"^",9)
IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,$PIECE(X,"^",9)))
SET LRX=$PIECE(X,"^",9)
+14 SET LRTEST(LRNT,"P")=LRX_U_$$NLT^LRVER1(LRX)_"!"
+15 SET ^TMP("LR",$JOB,"VTO",+X,"P")=$PIECE(LRTEST(LRNT,"P"),"!")
End DoDot:1
+16 ;
TEST1 ; from LRFLAG
+1 ;
+2 NEW LRI
+3 FOR LRI=1:1:LRNT
if $DATA(^LAB(60,+LRTEST(LRI),0))
SET (LRTEST(LRI),LRBETST(LRI))=LRTEST(LRI)_U_^(0)
+4 IF $GET(LRORDR)'="P"
KILL ^TMP("LR",$JOB,"TMP")
+5 SET LRNX=0
+6 KILL LRM
+7 FOR I=1:1
if '$DATA(LRTEST(I))
QUIT
Begin DoDot:1
+8 SET X=LRTEST(I)
SET XP=$GET(LRTEST(I,"P"))
+9 KILL LRTEST(I)
+10 DO EX2
End DoDot:1
+11 KILL LRTEST
+12 QUIT
+13 ;
+14 ;
EX2 ;
+1 ; If dataname then process and quit
+2 SET LRSUB=$PIECE(X,U,6)
+3 IF LRSUB'=""
Begin DoDot:1
+4 SET LRSB=$PIECE(LRSUB,";",2)
+5 if '$DATA(LRVTS(LRSB))
QUIT
+6 IF $DATA(^TMP("LR",$JOB,"TMP",LRSB))
SET ^(LRSB,"P")=XP
+7 SET ^TMP("LR",$JOB,"TMP",LRSB)=+X
+8 SET XP=XP_$$RNLT^LRVER1(+X)
+9 SET ^TMP("LR",$JOB,"TMP",LRSB,"P")=XP
+10 if $PIECE(X,U,18)
SET LRM(LRSB)=+X
SET LRM(LRSB,"P")=XP
+11 ; CIDC
SET LRBEY(+X,LRSB)=""
End DoDot:1
QUIT
+12 ;
+13 IF $DATA(^LAB(60,+X,4))
IF $PIECE(^(4),"^",2)
SET LRCFL=LRCFL_$PIECE(^(4),"^",2)_U
+14 ;
+15 ; If panel then explode components of panel and
+16 ; set parent("P" node) to file #60 test being exploded
+17 SET J=0
+18 FOR
SET J=$ORDER(^LAB(60,+X,2,J))
if J<1
QUIT
IF $DATA(^(J,0))#2
Begin DoDot:1
+19 SET Y=^LAB(60,+X,2,J,0)
+20 ;quit if merged or not performed - LR*5.2*524
+21 if $LENGTH($PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+Y,0)),U,6))
QUIT
+22 SET LRNT=LRNT+1
+23 SET LRTEST(LRNT)=+Y_U_^LAB(60,+Y,0)
+24 SET LRTEST(LRNT,"P")=+XP_U_$$NLT^LRVER1(+XP)_"!"
End DoDot:1
+25 QUIT
+26 ;
+27 ;
QUIT QUIT
+1 ;
+2 ;
WAIT WRITE !,"Type ""^"" to skip "
WAIT1 READ X:10
+1 if X[U
GOTO LRVR1
if $ORDER(^LAH(LRLL,1,"C",LRAN,0))<1
GOTO WAIT1
+2 GOTO LRVR1
+3 ;
+4 ;
SEQDISP(LRLL,LRISQN) ; Display test results for a LAH entry.
+1 ; Call with LRLL = ien of enry in LAH
+2 ; LRISQN = sequence ien of enry in LAH
+3 ;
+4 NEW LR60,LRI,LRJ,LRSB,LRX,LRY
+5 ;
+6 WRITE !!,"Results for Sequence #"_LRISQN
+7 ;
+8 IF $ORDER(^LAH(LRLL,1,LRISQN,1))
Begin DoDot:1
+9 WRITE !,"Test",?25,"Value",?40,"Flag",?50,"Units"
+10 WRITE !,"----",?25,"-----",?40,"----",?50,"-----"
End DoDot:1
+11 ;
+12 ; Display CH subsript results.
+13 SET LRSB=1
+14 FOR
SET LRSB=$ORDER(^LAH(LRLL,1,LRISQN,LRSB))
if LRSB<1
QUIT
Begin DoDot:1
+15 SET LRX=^LAH(LRLL,1,LRISQN,LRSB)
+16 SET LR60=+$ORDER(^LAB(60,"C","CH;"_LRSB_";1",0))
+17 SET LR60(0)=$GET(^LAB(60,LR60,0))
+18 WRITE !,$EXTRACT($PIECE(LR60(0),"^"),1,24),?25," ",$PIECE(LRX,"^"),?39," ",$PIECE(LRX,"^",2),?49," ",$PIECE($PIECE(LRX,"^",5),"!",7)
End DoDot:1
+19 ;
+20 ; Display comments
+21 IF $DATA(^LAH(LRLL,1,LRISQN,1))
Begin DoDot:1
+22 WRITE !,"Comments"
+23 SET (LRI,LRY)=0
SET LRJ=""
+24 FOR
SET LRY=$ORDER(^LAH(LRLL,1,LRISQN,1,LRY))
if LRY<1
QUIT
Begin DoDot:2
+25 SET LRX=^LAH(LRLL,1,LRISQN,1,LRY)
SET LRI=LRI+1
+26 WRITE !,"#",LRI," ",$PIECE(LRX,"^")
+27 IF $PIECE(LRX,"^",2)
SET LRJ=LRJ_$SELECT(LRJ'="":",",1:"")_LRJ
End DoDot:2
+28 WRITE !,"Comments # ",LRJ," previously processed"
End DoDot:1
+29 ;
+30 WRITE !
+31 ;
+32 QUIT
