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

LRVR3.m

Go to the documentation of this file. 
  1. LRVR3 ;DALOI/CJS/JAH - LAB ROUTINE DATA VERIFICATION ; 03-Oct-2016 10:28 ; MKK
  1.  ;;5.2;LAB SERVICE;**42,121,153,1018,286,1027,291,1031,1038,1039**;NOV 1, 1997;Build 38
  1.  ;
  1.  D V1
  1.  I $D(LRLOCKER)#2 L -@(LRLOCKER) K LRLOCKER
  1.  K LRSA,LRSB,LRNOVER,LRSBCOM,LRLKOK
  1.  Q  ;Leave LRVR3, back to LRVR2
  1.  ;
  1.  ;
  1. V1 S LRTN=1
  1.  I $D(LRLOCKER)#2 L -@(LRLOCKER)
  1.  S LRLOCKER="^LR("_LRDFN_","""_LRSS_""","_LRIDT_")"
  1.  L +@(LRLOCKER):1
  1.  I '$T W !," This entry is being edited by someone else." Q
  1.  ;LRNOVER set in LRVR2
  1.  K LRLKOK D LINK Q:'$D(LRLKOK)  K LRLKOK D LKCHK Q:'$D(LRLKOK)
  1.  K LRSA,LRSB,LRSBCOM
  1.  ;
  1.  S LRCMTDSP=$$CHKCDSP^LRVERA
  1.  N LRX
  1.  S LRX=1
  1.  F  S LRX=$O(^LAH(LRLL,1,LRSQ,LRX)) Q:LRX<1  D
  1.  . Q:LRX=9009027                       ; IHS/OIT/MKK LR*5.2*1027 - Skip E-SIG Entry
  1.  . S LRSB(LRX)=^LAH(LRLL,1,LRSQ,LRX)
  1.  . I $D(LRNOVER),$D(LRVTS(LRX)),$D(^TMP("LR",$J,"TMP",LRX)) S LRNOVER(LRX)=""
  1.  ; Copy comments from LAH
  1.  S LRX=0
  1.  ; F  S LRX=$O(^LAH(LRLL,1,LRSQ,1,LRX)) Q:LRX=""  S LRSBCOM(LRX)=^(LRX)
  1.  ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
  1.  F  S LRX=$O(^LAH(LRLL,1,LRSQ,1,LRX)) Q:LRX=""  D
  1.  . Q:LRX=9009027                       ; Skip E-SIG Entry
  1.  . S LRSBCOM(LRX)=^LAH(LRLL,1,LRSQ,1,LRX)
  1.  ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
  1.  ;
  1. EDIT I $D(^LAH(LRLL,1,LRSQ,0)) D
  1.  . N X
  1.  . S LREDIT=1
  1.  . F LRX=0,.1,.3 M X(LRX)=^LAH(LRLL,1,LRSQ,LRX)
  1.  . K ^LAH(LRLL,1,LRSQ),LRNUF
  1.  . F LRX=0,.1,.3 M ^LAH(LRLL,1,LRSQ,LRX)=X(LRX) K X(LRX)
  1.  . D ^LRVR4
  1.  . F LRX=1:0 S LRX=$O(LRSB(LRX)) Q:LRX<1  S ^LAH(LRLL,1,LRSQ,LRX)=LRSB(LRX)
  1.  I $O(^LAH(LRLL,1,LRSQ,1))<1 W !,"NO DATA TO APPROVE" Q
  1.  Q:$D(LRGVP)
  1.  F I=0:0 S I=$O(LRNOVER(I)) Q:I=""  W !,$P(^DD(63.04,I,0),U)
  1.  I $O(LRNOVER(0)) W !,"Have not been reviewed and have data.  Not approved." QUIT
  1.  I '$P($G(LRLABKY),U) W !,$C(7),"ENTERED BUT NOT APPROVED" QUIT
  1.  N CNT S CNT=1
  1. AGAIN ;
  1.  ; R !,"Approve for release by entering your initials: ",LRINI:DTIME
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038 -- Mask User input.
  1.  D  ; DO Statement used to ensure variables ANSWER, STEP, & TEXT are strictly local
  1.  . NEW ANSWER,STEP,TEXT
  1.  . W !,"Approve for release by entering your initials: "
  1.  . S ANSWER=""
  1.  . ; F STEP=1:1:4  R TEXT#1  S:TEXT="^" ANSWER="^"  Q:TEXT="^"!(TEXT="")  S ANSWER=ANSWER_TEXT  W $C(8),"*"
  1.  . 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
  1.  . S LRINI=ANSWER
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1038
  1.  ;
  1.  I $E(LRINI)="^" W !!?5,$C(7),"Nothing verified!" D READ Q
  1.  I LRINI'=LRUSI,$$UP^XLFSTR(LRINI)=$$UP^XLFSTR(LRUSI) S LRINI=LRUSI
  1.  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
  1.  I LRINI'=LRUSI W !!?5,$C(7),"Nothing verified!" D READ Q
  1.  ;
  1. V11 ;Still locked from V1 L ^LR(LRDFN,LRSS,LRIDT)
  1.  N LRCORECT S LRCORECT=0
  1.  N LRX
  1.  NEW LRNOW  S LRNOW=$$NOW^XLFDT  ; IHS/MSC/MKK - LR*5.2*1039 - LEDI IV Update
  1.  S LRX=0
  1.  F  S LRX=$O(^TMP("LR",$J,"TMP",LRX)) Q:LRX<1  I $D(LRVTS(LRX)),$D(LRSB(LRX)),$D(^(LRX)) D
  1.  . K ^LAH(LRLL,1,LRSQ,LRX)
  1.  . ; I LRSB(LRX)'="" S ^LR(LRDFN,LRSS,LRIDT,LRX)=LRSB(LRX) S:'$D(^LRO(68,"AC",LRDFN,LRIDT,LRX)) ^(LRX)="" I LRVF S ^(LRX)=""
  1.  . I LRSB(LRX)'="" S $P(LRSB(LRX),U,6)=LRNOW,^LR(LRDFN,LRSS,LRIDT,LRX)=LRSB(LRX) S:'$D(^LRO(68,"AC",LRDFN,LRIDT,LRX)) ^(LRX)="" I LRVF S ^(LRX)=""  ; IHS/MSC/MKK - LR*5.2*1039 - LEDI IV Update
  1.  ;
  1.  I $P($G(LRORU3),U,3),$O(LRSB(0)) D LRORU3^LRVER3
  1.  ;
  1. A3 I +LRDPF=2&($G(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT)) D
  1.  .D BAWRK^LRBEBA(LRODT,LRSN,1,.LRBEY,.LRBETST)
  1.  D VER^LRVER3A ;unlocked in LRVER
  1.  K LRSBCOM
  1.  D:$P(LRPARAM,U,14)&($P($G(^LRO(68,LRAA,0)),U,16)) LOOK^LRCAPV1
  1.  ; Check for LEDI tests not reviewed
  1.  I $G(LRDUZ(2)),LRDUZ(2)'=DUZ(2),LRSS="CH",'$D(ZTQUEUED) D TNR
  1.  ;
  1.  I +$O(^LAH(LRLL,1,LRSQ,1))<1 D ZAPALL(LRLL,LRSQ)
  1.  I $D(LRPRGSQ),'$D(ZTQUEUED) D
  1.  . W !,"Purge data from sequence number(s): "
  1.  . F I=0:0 S I=$O(LRPRGSQ(I)) Q:I<1  W " ",I
  1.  . S %=1 D YN^DICN Q:%'=1
  1.  . N LAIEN
  1.  . S LAIEN=0
  1.  . F  S LAIEN=$O(LRPRGSQ(LAIEN)) Q:LAIEN<1  D ZAPALL(LRLL,LAIEN)
  1.  Q
  1.  ;
  1.  ;
  1. ZAP ; from LRLLS3
  1.  D ZAPALL(LRLL,I)
  1.  Q
  1.  ;
  1.  ;
  1.  D LKCHK Q:$D(LRLKOK)  S X=$S($D(^LRO(68,+$P(LRLK,U,3),1,+$P(LRLK,U,4),1,+$P(LRLK,U,5),0)):+^(0),1:"") G LINKOK:+X=LRDFN
  1.  ; S S1=PNM,S2=SSN,S3=LRDPF W !,$C(7),"WARNING - NO MATCHING ACCESSION WAS FOUND.",!,"You may need to Clear instrument/worklist data,",!,"or correctly identify the sample to the system."
  1.  ; I X S LRDPF=$P(^LR(X,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM,?30,SSN,!,$C(7) S PNM=S1,SSN=S2,LRDPF=S3
  1.  ; 
  1.  ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
  1.  S S1=PNM,S2=HRCN,S3=LRDPF
  1.  W !,$C(7),"WARNING - NO MATCHING ACCESSION WAS FOUND."
  1.  W !,"You may need to Clear instrument/worklist data,"
  1.  W !,"or correctly identify the sample to the system."
  1.  I X S LRDPF=$P(^LR(X,0),U,2),DFN=$P(^(0),U,3) D
  1.  . D PT^LRX
  1.  . W !,PNM,?30,HRCN,!,$C(7)
  1.  . S PNM=S1,HRCN=S2,LRDPF=S3
  1.  ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
  1.  ;
  1.  K S1,S2,S3 Q:$D(LRGVP)  W !,"ARE YOU SURE THIS IS THE CORRECT DATA" S %=2 D YN^DICN Q:%'=1
  1. LINKOK K:$P(LRLK,U,5) ^LAH(LRLL,1,"C",+$P(LRLK,U,5),LRSQ)
  1.  S ^LAH(LRLL,1,"C",LRAN,LRSQ)="",$P(^LAH(LRLL,1,LRSQ,0),U,3,5)=LRAA_U_LRAD_U_LRAN,LRLKOK=1
  1.  Q
  1.  ;
  1. LKCHK S LRLK=$S($D(^LAH(LRLL,1,LRSQ,0)):^(0),1:"") I $P(LRLK,U,3)=LRAA&($P(LRLK,U,4)=LRAD)&($P(LRLK,U,5)=LRAN) S LRLKOK=1
  1.  Q
  1.  ;
  1.  ;
  1. ZAP2 ;Clear ^LAH(
  1.  D ZAPALL(LRLL,I)
  1.  Q
  1.  ;
  1.  ;
  1. ZAPALL(LRLL,LAIEN) ;Clean up
  1.  N I,NODE,SEG,SUB
  1.  Q:'$G(LRLL)!('$G(LAIEN))
  1.  ;
  1.  S NODE=$G(^LAH(LRLL,1,LAIEN,0))
  1.  K ^LAH(LRLL,1,"B",+$P(NODE,U)_";"_+$P(NODE,U,2),LAIEN)
  1.  K ^LAH(LRLL,1,"C",+$P(NODE,U,5),LAIEN)
  1.  K ^LAH(LRLL,1,"D",+$P(NODE,U,6),LAIEN)
  1.  K ^LAH(LRLL,1,"E",+$P(NODE,U,8),LAIEN)
  1.  ;
  1.  S NODE("U")=$P($G(^LAH(LRLL,1,LAIEN,.3)),U)
  1.  I NODE("U")'="" D
  1.  . K ^LAH(LRLL,1,"U",NODE("U"),LAIEN)
  1.  . S I=0
  1.  . F  S I=$O(^LAH("LA7 AMENDED RESULTS",NODE("U"),I)) Q:'I  D
  1.  . . K ^LAH("LA7 AMENDED RESULTS",NODE("U"),I,LRLL,LAIEN)
  1.  ;
  1.  S SEG=""
  1.  F  S SEG=$O(^LAH(LRLL,1,LAIEN,.1,SEG)) Q:SEG=""  D
  1.  . S SEGID=""
  1.  . F  S SEGID=$O(^LAH(LRLL,1,LAIEN,.1,SEG,SEGID)) Q:SEGID=""  D
  1.  . . S SUB=$P($G(^LAH(LRLL,1,LAIEN,.1,SEG,SEGID)),U)
  1.  . . I SUB'="" K ^LAH(LRLL,1,"A"_SEGID,SUB,LAIEN)
  1.  ;
  1.  K ^LAH(LRLL,1,LAIEN)
  1.  ;
  1.  ; Reset counter if loadlist is clear.
  1.  I '$O(^LAH(LRLL,1,0)) D
  1.  . L +^LAH(LRLL):1 Q:'$T
  1.  . S ^LAH(LRLL)=0
  1.  . L -^LAH(LRLL)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. TNR ; List tests not reviewed and ask if user wants to delete.
  1.  ;
  1.  N DIR,DIROUT,DIRUT,DUOUT,LR60,I,X,Y
  1.  ;
  1.  ; Check if these results have already been verified
  1.  S I=1
  1.  F  S I=$O(^LAH(LRLL,1,LRSQ,I)) Q:'I  D
  1.  . S X=^LAH(LRLL,1,LRSQ,I)
  1.  . I $P(X,"^")=$P($G(^LR(LRDFN,LRSS,LRIDT,I)),"^") K ^LAH(LRLL,1,LRSQ,I)
  1.  ;
  1.  ; Quit if no unreviewed results
  1.  I +$O(^LAH(LRLL,1,LRSQ,1))'>1 Q
  1.  ;
  1.  W !,"Test(s) Not Reviewed:",!
  1.  S I=1
  1.  F  S I=$O(^LAH(LRLL,1,LRSQ,I)) Q:'I  D
  1.  . S X=^LAH(LRLL,1,LRSQ,I)
  1.  . S LR60=+$O(^LAB(60,"C","CH;"_I_";1",0))
  1.  . I LR60 W $$GET1^DIQ(60,LR60_",",.01)
  1.  . E  W $$GET1^DID(63.04,I,"","LABEL")
  1.  . W " = "_$P(X,"^")_" "_$P(X,"^",2)_"  "_$P($P(X,"^",5),"!",7),!
  1.  ;
  1.  S DIR(0)="Y",DIR("A")="Purge these test results",DIR("B")="NO"
  1.  S DIR("?",1)="Answer 'NO' if you want to keep these results for later verification."
  1.  S DIR("?",2)="You may need to add these tests to the loadlist profile your using"
  1.  S DIR("?")="and/or add these tests to the accession your verifying."
  1.  D ^DIR Q:$D(DIRUT)
  1.  ;
  1.  I Y=1 D ZAPALL(LRLL,LRSQ)
  1.  Q
  1.  ;
  1.  ;
  1. READ ;
  1.  N X W !!,"Press ENTER or RETURN to continue: " R X:DTIME
  1.  Q