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