Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRVR1

LRVR1.m

Go to the documentation of this file. 
  1. LRVR1 ;DALOI/CJS/JAH - LAB ROUTINE DATA VERIFICATION ;8/10/04
  1.  ;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
  1.  ;
  1.  ;;VA LR Patch(s): 42,153,221,286,291
  1.  ;
  1.  N LRI,LRN,LRBETST,LRBEY
  1.  S (LRI,LRN)=0
  1.  F  S LRI=$O(^LAH(LRLL,1,"C",LRAN,LRI)) Q:LRI<1  D
  1.  . N LRX
  1.  . S LRX=$G(^LAH(LRLL,1,LRI,0))
  1.  . ; Quit if different accession area.
  1.  . I $P(LRX,"^",3),$P(LRX,"^",3)'=LRAA Q
  1.  . ; Quit if different accession date and not a rollover accession (same original accession date).
  1.  . 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
  1.  . I LRN W !
  1.  . S LRN=LRN+1,LRSQ=LRI
  1.  . W !,?2,"Seq #: ",LRI,?13," Accession: ",$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^")
  1.  . I $P(LRX,"^",10) W ?40," Results received: ",$$FMTE^XLFDT($P(LRX,"^",10),"1M")
  1.  . W !,?20,"UID: ",$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),"UNKNOWN"),"^")
  1.  . I $P(LRX,"^",11) W ?44," Last updated: ",$$FMTE^XLFDT($P(LRX,"^",11),"1M")
  1.  G VER:LRN=1,T3:LRN>1
  1.  ;
  1.  ; If attempting to verify reference lab results and no entry in LAH
  1.  ; associated with this accession then quit - do not allow manual entry
  1.  ; of ref lab results via this option. Will not store units/normals.
  1.  I $G(LRDUZ(2)),DUZ(2)'=LRDUZ(2) W !,"No data there" Q
  1.  ;
  1. T1 R !,"What tray: ",X:DTIME Q:X["^"!'$T  I X["?"!(X'?.N) W !,"Enter a number" G T1
  1.  I X'="" S LRTRAY=X G T2
  1.  I $D(^LRO(68.2,"AS",LRLL)) W !,"Can't MANUALLY add to a SEQUENCE instrument data file." G QUIT
  1.  W !,"Enter manually" S %=1 D YN^DICN G QUIT:%<1,T1:%=2 S LRSQ=-1 G VER
  1.  G VER
  1. T2 R !,"What cup: ",X:DTIME Q:X["^"!'$T  I X["?"!(X'?.N) W !,"Enter a number" G T2
  1.  Q:X=""  S LRTRCP=LRTRAY_";"_X
  1.  K LRPRGSQ
  1.  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
  1. T3 I LRN=0 W !,"No data for that tray & cup" Q
  1.  I LRN>1 R !,"Choose sequence number: ",X:DTIME Q:'$T  I X["?"!(X'?.N) W !,"Enter a number" G T3
  1.  I X["^"!(X="") K LRPRGSQ Q
  1.  S:LRN'=1 LRSQ=X I '$D(^LAH(LRLL,1,LRSQ,0)) W !,"No data there" G T3
  1.  ;
  1. VER ; from LRFLAG, LRGP, LRVRW
  1.  N LRROOT
  1.  K LRTEST,LRNM,^TMP("LR",$J,"TMP")
  1.  S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
  1.  ;
  1.  ; Determine if there are amended results to process via "EM"
  1.  S LRROOT=$Q(^LAH("LA7 AMENDED RESULTS",LRUID,1,LRLL))
  1.  I LRROOT'="",$QS(LRROOT,1)="LA7 AMENDED RESULTS",$QS(LRROOT,2)=LRUID,$QS(LRROOT,4)=LRLL D  Q
  1.  . W !!,"Amended results exist for this accession. Please process these"
  1.  . W !,"first using option Enter/verify/modify data (manual) [LRENTER]"
  1.  ;
  1.  D TEST
  1.  I $O(^TMP("LR",$J,"TMP",0))="" W !,"No tests in editing profile" Q
  1.  S X=DUZ D DUZ^LRX
  1.  G V2:LRSQ>0
  1.  L +^LAH(LRLL)
  1.  S (^LAH(LRLL),LRSQ)=1+$G(^LAH(LRLL))
  1.  S ^LAH(LRLL,1,LRSQ,0)="^^"_LRAA_"^"_LRAD_"^"_LRAN_"^^MANUAL"
  1.  D UID^LAGEN(LRLL,LRSQ,LRUID)
  1.  D UPDT^LAGEN(LRLL,LRSQ)
  1.  S ^LAH(LRLL,1,"C",LRAN,LRSQ)=""
  1.  L -^LAH(LRLL)
  1. V2 K LRPRGSQ(LRSQ)
  1.  S LRLLOC=0,LROUTINE=$P(^LAB(69.9,1,3),U,2)
  1.  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)
  1.  S LRCDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U)
  1.  I '$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",3) D
  1.  . N %DT,LRA1,LRA2,LRA3
  1.  . S %DT("B")=$$FMTE^XLFDT(LRCDT,"1")
  1.  . S LRSTATUS="C",LRA1=LRAA,LRA2=LRAD,LRA3=LRAN
  1.  . D P15^LROE1
  1.  . S LRAA=LRA1,LRAD=LRA2,LRAN=LRA3
  1.  . I LRCDT<1 Q
  1.  . I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,3) S $P(^(3),U,3)=$$NOW^XLFDT
  1.  ; If user did not update then go to next
  1.  I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,3) Q
  1.  S LRCDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U)
  1.  I LRCDT<1 Q
  1.  S LREAL=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,2),LRALERT=LROUTINE
  1.  S I=0
  1.  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
  1.  . I $G(LRAL) S LRALERT=$S(LRAL<50&(LRAL<LRALERT):LRAL,LRAL>50&(LRAL-50<LRALERT):LRAL-50,1:LRALERT)
  1.  S LRSAMP=$P($G(^LRO(69,LRODT,1,LRSN,0)),U,3)
  1.  ;
  1.  S LRSS=$P(^LRO(68,LRAA,0),U,2)
  1.  I LRSS'="CH" Q
  1.  ; Check for valid pointer to file #63 and entry in file #63.
  1.  S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
  1.  I LRIDT<1 W !,">>>>ERROR - NO POINTER TO FILE #63 - PLEASE NOTIFY SYSTEM MANAGER^ <<<<<",! Q
  1.  I '$D(^LR(LRDFN,LRSS,LRIDT,0)) W !,">>>>ERROR - NO ENTRY IN FILE #63 - PLEASE NOTIFY SYSTEM MANAGER<<^ <<<",! Q
  1.  ;
  1.  S LRCW=8
  1. LD S LRSS="CH"
  1.  I '($D(^LAH(LRLL,1,LRSQ,0))#2) W !!?5,"No Data for this Accession ",!! K ^LAH(LRLL,1,LRSQ),^LAH(LRLL,1,"C",LRAN,LRSQ) K LRPRGSQ Q
  1.  ;
  1.  ; Store any new methods with existing methods on file.
  1.  S LRMETH=$P(^LAH(LRLL,1,LRSQ,0),U,7) S:$D(LRGVP) LRMETH=LRMETH_"(GV)"
  1.  I $P($G(^LR(LRDFN,LRSS,LRIDT,0)),U,8)'="" D
  1.  . N I,X
  1.  . S X=$P(^LR(LRDFN,LRSS,LRIDT,0),U,8)
  1.  . F I=1:1:$L(X,";") I $P(X,";",I)'="",LRMETH'[$P(X,";",I) S LRMETH=LRMETH_";"_$P(X,";",I)
  1.  I LRMETH'="" S $P(^LR(LRDFN,LRSS,LRIDT,0),U,8)=LRMETH
  1.  ;
  1.  W:$D(^LAB(62,+LRSAMP,0)) !,"Sample: ",$P(^(0),U)
  1.  ;
  1.  D ^LRVR2
  1.  K LRDL,LRPRGSQ
  1.  Q  ; leave LRVR1, back to LRVR
  1.  ;
  1.  ;
  1. TEST ; from LRGV1
  1.  N LRI,LRX
  1.  S LRI=0
  1.  F  S LRI=$O(^TMP("LR",$J,"VTO",LRI)) Q:LRI<1  K ^(LRI,"P")
  1.  S (LRI,LRNT)=0
  1.  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
  1.  . S LRNT=LRNT+1,LRTEST(LRNT)=+X,LRX=$S($P(X,"^",2)>50:$P(X,"^",9),1:$P(X,"^"))
  1.  . S LRTEST(LRNT,"P")=LRX_U_$$NLT^LRVER1(LRX)_"!"
  1.  . S ^TMP("LR",$J,"VTO",+X,"P")=$P(LRTEST(LRNT,"P"),"!")
  1.  ;
  1. TEST1 ; from LRFLAG
  1.  ;
  1.  N LRI
  1.  F LRI=1:1:LRNT S:$D(^LAB(60,+LRTEST(LRI),0)) (LRTEST(LRI),LRBETST(LRI))=LRTEST(LRI)_U_^(0)
  1.  I $G(LRORDR)'="P" K ^TMP("LR",$J,"TMP")
  1.  S LRNX=0
  1.  K LRM
  1.  F I=1:1 Q:'$D(LRTEST(I))  D
  1.  . S X=LRTEST(I),XP=$G(LRTEST(I,"P"))
  1.  . K LRTEST(I)
  1.  . D EX2
  1.  K LRTEST
  1.  Q
  1.  ;
  1.  ;
  1. EX2 ;
  1.  ; If dataname then process and quit
  1.  S LRSUB=$P(X,U,6)
  1.  I LRSUB'="" D  Q
  1.  . S LRSB=$P(LRSUB,";",2)
  1.  . Q:'$D(LRVTS(LRSB))
  1.  . I $D(^TMP("LR",$J,"TMP",LRSB)) S ^(LRSB,"P")=XP
  1.  . Q:$D(^TMP("LR",$J,"TMP",LRSB))
  1.  . S ^TMP("LR",$J,"TMP",LRSB)=+X
  1.  . S XP=XP_$$RNLT^LRVER1(+X)
  1.  . S ^TMP("LR",$J,"TMP",LRSB,"P")=XP
  1.  . S:$P(X,U,18) LRM(LRSB)=+X,LRM(LRSB,"P")=XP
  1.  . S LRBEY(+XP,LRSB)=""     ; CIDC
  1.  ;
  1.  I $D(^LAB(60,+X,4)),$P(^(4),"^",2) S LRCFL=LRCFL_$P(^(4),"^",2)_U
  1.  ;
  1.  ; If panel then explode components of panel and
  1.  ;  set parent("P" node) to file #60 test being exploded
  1.  S J=0
  1.  F  S J=$O(^LAB(60,+X,2,J)) Q:J<1  I $D(^(J,0))#2 D
  1.  . S LRNT=LRNT+1,Y=^LAB(60,+X,2,J,0)
  1.  . S LRTEST(LRNT)=+Y_U_^LAB(60,+Y,0)
  1.  . S LRTEST(LRNT,"P")=+XP_U_$$NLT^LRVER1(+XP)_"!"
  1.  Q
  1.  ;
  1.  ;
  1. QUIT Q
  1.  ;
  1. WAIT W !,"Type ""^"" to skip "
  1. WAIT1 R X:10 G LRVR1:X[U,WAIT1:$O(^LAH(LRLL,1,"C",LRAN,0))<1 G LRVR1