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

LRVR.m

Go to the documentation of this file. 
  1. LRVR ;DALOI/CJS/DALOI/FHS - LAB ROUTINE DATA VERIFICATION ;JUL 06, 2010 3:14 PM
  1.  ;;5.2;LAB SERVICE;**42,153,263,286,1027**;NOV 01, 1997
  1.  N LRDUZ,LRVBY
  1.  D INIT G QUIT:$G(LREND)
  1.  S LRVBY=$$SELBY^LRWU4("Verify by")
  1.  I LRVBY=0 D QUIT Q
  1.  I LRVBY=2 D ^LRVRA,QUIT Q
  1. DAT D ADATE^LRWU G:LRAD<1 QUIT
  1.  I $P(^LRO(68,LRAA,0),U,3)="D" F I=0:0 S I=$O(^LRO(68,LRAA,1,LRAD,1,I)) Q:I<1  I $D(^LRO(68,LRAA,1,LRAD,1,I,3)),'$P(^(3),U,4) S LRAN=I Q
  1.  S:$D(^LRO(68,LRAA,1,LRAD,2))&'LRAN LRAN=$P(^(2),U,4)
  1.  D
  1.  . N X
  1.  . S X=$S(+$P($G(^LAB(69.9,1,0)),U,7):+$P(^(0),U,7),1:1)
  1.  . S LRTM60=9999999-$$FMADD^XLFDT(DT,-X)
  1. L10 S LRCFL="",EAMODE=1
  1.  K LRTEST,C5,LRSET,LRLDT,DIC,LRNM,LRNG,LRDL,LRDEL,T,LRFP,LRAB,LRVER,Y,Z
  1.  D WLN G QUIT:LREND
  1.  D ^LRVR1,NEXT
  1.  G L10
  1.  ;
  1.  ;
  1. YN R X:DTIME Q:X=""!(X["N")!(X["Y")  W !,"Answer 'Y' or 'N': " G YN
  1.  ;
  1. WLN ;
  1.  S LRNOP=0
  1.  K DIR,DIRUT,DTOUT,DUOUT
  1.  S DIR(0)="NAO^1:999999:0"
  1.  S DIR("A")="Accession NUMBER: ",DIR("?")="^D LW^LRVR"
  1.  I LRAN'="" S DIR("B")=LRAN
  1.  D ^DIR K DIR
  1.  I $D(DIRUT) G STOP
  1.  S LRAN=Y
  1.  I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"NOT ON FILE" S LRNOP=1
  1.  I '$G(LRNOP) D
  1.  . S LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRCEN=$S($D(^(.1)):^(.1),1:0),LRODT=$S($P(^(0),U,4):$P(^(0),U,4),1:$P(^(0),U,3)),LRSN=$P(^(0),U,5)
  1.  . S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
  1.  I '$G(LRNOP),$P(LRORU3,U)="" W !?10,"No UID number for this accession",! S LRNOP=1
  1.  ; I '$G(LRNOP) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM,?30,SSN W:LRCEN !,"ORDER #: ",LRCEN
  1.  ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
  1.  I '$G(LRNOP) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM,?30,HRCN W:LRCEN !,"ORDER #: ",LRCEN
  1.  ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
  1.  S LRCDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U)
  1.  I '$G(LRNOP),'$P($G(^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 S LRNOP=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 accession
  1.  I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,3) S LRNOP=1
  1.  S LRCDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U)
  1.  I $G(LRCDT)<1 S (LRCDT,LRNOP)=1
  1.  ;
  1.  S LRSS=$P(^LRO(68,LRAA,0),U,2)
  1.  I '$G(LRNOP),LRSS'="CH" S LRNOP=1
  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 '$G(LRNOP),LRIDT<1 W !,">>>>ERROR - NO POINTER TO FILE #63 - PLEASE NOTIFY SYSTEM MANAGER^ <<<<<",! S LRNOP=1
  1.  I '$G(LRNOP),'$D(^LR(LRDFN,LRSS,LRIDT,0)) W !,">>>>ERROR - NO ENTRY IN FILE #63 - PLEASE NOTIFY SYSTEM MANAGER<<^ <<<",! S LRNOP=1
  1.  ;
  1.  I '$G(LRNOP),$D(^LRO(69,LRODT,1,LRSN)),'$D(^(LRSN,1)) W !,"This Order # has not been collected",$C(7) S LRNOP=1
  1.  I '$G(LRNOP),$D(^LRO(69,LRODT,1,LRSN,1)),$P(^LRO(69,LRODT,1,LRSN,1),U,4)'="C" W !,"You cannot verify an accession which has not been collected.",$C(7) S LRNOP=1
  1.  I $G(LRNOP) D NEXT G WLN
  1.  Q
  1.  ;
  1.  ;
  1. LW ;
  1.  N S
  1.  W !,"Enter range of accession numbers which might apply."
  1.  D LRAN^LRWU3 Q:LREND
  1.  S LRDT=$$FMTE^XLFDT($$DT^XLFDT,"5F")
  1.  S S("LRAA")=LRAA,S("LRAD")=LRAD,S("LRAN")=LRAN
  1.  D W^LRWRKLST
  1.  S LREND=0,LRAA=S("LRAA"),LRAD=S("LRAD"),LRAN=S("LRAN")
  1.  Q
  1.  ;
  1.  ;
  1. QUIT I $G(LRAN),$G(LRAA),$G(LRAD) S LREND=1 I $D(^LRO(68,LRAA,1,LRAD,0)) S:'$D(^(2)) ^(2)="^^" S ^(2)=$P(^(2),U,1,3)_U_LRAN_U_$P(^(2),U,5,99),LREND=1
  1.  ;
  1. CLEAN ;
  1.  I $D(LRCSQ),'$O(^XTMP("LRCAP",LRCSQ,DUZ,0)) K ^XTMP("LRCAP",LRCSQ,DUZ)
  1.  E  I $D(LRAA) D:$P(LRPARAM,U,14)&($P($G(^LRO(68,+LRAA,0)),U,16)) STD^LRCAPV K LRIDIV
  1.  K DIR,LRCMTDSP,LRNOP,XP
  1.  D ^LRVRKIL
  1.  S ZTIO="",ZTRTN="LRCAPV2",ZTDTH=$H,ZTDESC="LAB LRCAPV2 ROUTINE"
  1.  D ^%ZTLOAD K ZTSK
  1.  Q
  1.  ;
  1.  ;
  1. NEXT S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) I LRAN'>0 W !,"LAST IN WORK LIST" S LRAN="^"
  1.  S LREND=0
  1.  Q
  1.  ;
  1.  ;
  1. LIST W " the following tests: " F I=0:0 S I=$O(LRTST(I)) Q:I<1  W !,?10,$P(LRTST(I),"^",1)
  1.  Q
  1.  ;
  1.  ;
  1. EXPAND D EXPLODE^LRGP2
  1. SKPEX Q:$O(LRVTS(0))  ; READY TO GO
  1. STOP S LREND=1
  1.  Q
  1.  ;
  1.  ;
  1. INIT ;from LRVRW
  1.  N DIC,LRX
  1.  D ^LRPARAM Q:$G(LREND)  S LREND=0,LRAN=0 K LRORD,LRDUZ
  1.  S DIC="^LRO(68.2,",DIC(0)="AEMZ",DIC("S")="S LRX=$P(^(0),U,12) Q:'$L(LRX)  I $D(^XUSEC($P($G(^DIC(19.1,LRX,0)),U),DUZ))"
  1.  D ^DIC K DIC("S") G STOP:Y<1 S LRLL=+Y,LRTYPE=$P(Y(0),U,3)
  1.  S LRPROF=$O(^LRO(68.2,LRLL,10,0))
  1.  I LRPROF<1 S LREND=1 W !,"No profile defined." Q
  1.  S B=$O(^LRO(68.2,LRLL,10,LRPROF))
  1.  I B>0 S DIC="^LRO(68.2,"_LRLL_",10," D ^DIC G STOP:Y<1 S LRPROF=+Y
  1.  S X=^LRO(68.2,LRLL,10,LRPROF,0),LRAA=$P(X,U,2),LRPANEL=$P(X,U) I '$D(^LRO(68,LRAA,0))#2 W !?10,$C(7),"Error in your DATABASE. There is not an accession area # ",LRAA,!! Q
  1.  ;
  1.  ; Select performing laboratory to use
  1.  S LRX=$$SELPL^LRVERA($S($P(X,"^",5):$P(X,"^",5),1:DUZ(2)))
  1.  I LRX<1 S LREND=1 Q
  1.  I LRX,LRX'=DUZ(2) S LRDUZ(2)=LRX
  1.  ;
  1.  D:$P(LRPARAM,U,14)&($P($G(^LRO(68,LRAA,0)),U,16)) AUTO^LRCAPV Q:LREND
  1.  I $P(^LRO(68,LRAA,0),U,2)="MI" D ^LRMIEDZ S LREND=1 Q
  1.  G STOP:$P(^LRO(68,LRAA,0),U,2)'="CH"
  1.  S LREND=0 D EXPAND G STOP:LREND!($O(LRVTS(0))<0)
  1.  F I=0:0 S I=$O(LRORD(I)) Q:I<1  S J=LRORD(I),X=$P(^LAB(60,J,0),U,5),LRORD(I)=$P(X,";",2)
  1.  S Y=^LRO(68,LRAA,0),LRTSE=-1
  1.  ;
  1.  D CMTDSP^LRVERA
  1.  ;
  1. REV ;
  1.  K LRPER
  1.  D REV^LRVER
  1.  Q