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

LRVRA.m

Go to the documentation of this file. 
  1. LRVRA ;DALOI/JMC-Lab Routine Data Verification by UID ;06/04/10  19:12
  1.  ;;5.2;LAB SERVICE;**153,221,263,350**;Sep 27, 1994;Build 230
  1.  ;
  1.  ;
  1.  N LRANYAA,LRUID,LRNOP
  1.  S LRANYAA=+$P($G(^LRO(68.2,LRLL,10,LRPROF,0)),"^",3)
  1.  S LRUID="" D NEXT
  1.  ;
  1.  F  D  Q:LREND
  1.  . K LRTEST,C5,LRSET,LRLDT,DIC,LRNM,LRNG,LRDL,LRDEL,T,LRFP,LRAB,LRVER,Y,Z
  1.  . S LRCFL="",EAMODE=1
  1.  . N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  . D WLN I $G(LRNOP) D NEXT Q
  1.  . D ^LRVR1,NEXT
  1.  Q
  1.  ;
  1.  ;
  1. WLN ; Select next accession (UID) to work with.
  1.  W ! S LRNOP=0
  1.  K DIR
  1.  S DIR(0)="FO^1:10",DIR("A")="Unique Identifier",DIR("?")="^D LW^LRVRA"
  1.  I LRUID'="" S DIR("B")=LRUID
  1.  D ^DIR
  1.  I $D(DIRUT) D STOP^LRVR S LRNOP=1 Q
  1.  S LRUID=Y
  1.  I LRUID'?1.10N S LRUID=$$UP^XLFSTR(LRUID)
  1.  I $L(LRUID)<10 S LRUID=$$LWP(LRUID)
  1.  I $L(LRUID)<10 S LRUID="" G WLN
  1.  D UID
  1.  I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D  G WLN
  1.  . W !,"No accession on file for this UID."
  1.  . D NEXT
  1.  ;
  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 LRACC=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
  1.  S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
  1.  S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
  1.  D PT^LRX
  1.  ;
  1.  W !,PNM,?30,SSN_"  Age: "_AGE(2)
  1.  W !,"ORDER #: ",LRCEN,"    "_LRACC,"    [",LRUID_"]"
  1.  ;
  1.  I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",3) D
  1.  . N LRAA,LRAD,LRAN
  1.  . S LRSTATUS="C" D P15^LROE1
  1.  . I LRCDT<1 S LRNOP=1
  1.  I '$G(LRNOP),$P($G(^LRO(69,LRODT,1,LRSN,1)),U,4)'="C" D
  1.  . W !,"You cannot verify an accession which has not been collected.",$C(7)
  1.  . S LRNOP=1
  1.  I $G(LRNOP) D NEXT
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. LW ; Display list of UID's available
  1.  N DIR,DIRUT,DUOUT,DTOUT,I,J,K,L,LREND,X,Y
  1.  S LREND=0
  1.  S K=$$BLDHELP("",LRLL,LRPROF)
  1.  I 'K W !,$C(7),"No results found in UID cross-reference." Q
  1.  S J=IOSL-6,L=K\(J*2) S:'(K#(J*2)) L=L-1
  1.  F I=0:1:L D  Q:LREND
  1.  . W @IOF,$$CJ^XLFSTR("Current Unique Identifiers with Results Available",IOM)
  1.  . W !,$$CJ^XLFSTR("Associated with "_$$GET1^DIQ(68,LRAA_",",.02)_" subscript",IOM),!!
  1.  . F K=((J*2)*I)+1:1:((J*2)*I)+J D
  1.  . . W ?3,$P($G(^TMP($J,"LR","UIDHELP",K)),"^",2)
  1.  . . W ?43,$P($G(^TMP($J,"LR","UIDHELP",(K+J))),"^",2),!
  1.  . W ! S DIR(0)="E" D ^DIR
  1.  . I $D(DIRUT) D STOP^LRVR Q
  1.  K ^TMP($J,"LR","UIDHELP")
  1.  Q
  1.  ;
  1.  ;
  1. LWP(LRSD) ; Display list of partial UID's available
  1.  N DIR,DIRUT,DUOUT,DTOUT,I,J,K,L,LREND,LRUID,M,X,Y
  1.  S LRSD=$G(LRSD),(LREND,M)=0,LRUID=""
  1.  S K=$$BLDHELP(LRSD,LRLL,LRPROF)
  1.  I 'K W !,$C(7),"No results found in UID cross-reference." Q LRUID
  1.  S J=IOSL-6,L=K\(J*2) S:'(K#(J*2)) L=L-1
  1.  F I=0:1:L D  Q:LREND
  1.  . W @IOF,$$CJ^XLFSTR("Current Unique Identifiers with Results Available",IOM)
  1.  . W !,$$CJ^XLFSTR("Associated with "_$$GET1^DIQ(68,LRAA_",",.02)_" subscript",IOM),!!
  1.  . F K=((J*2)*I)+1:1:((J*2)*I)+J D
  1.  . . I $D(^TMP($J,"LR","UIDHELP",K)) D
  1.  . . . W ?3,$J(K,3),".  ",$P($G(^TMP($J,"LR","UIDHELP",K)),"^",2)
  1.  . . . I K>M S M=K
  1.  . . I $D(^TMP($J,"LR","UIDHELP",K+J)) D
  1.  . . . W ?43,$J(K+J,3),".  ",$P($G(^TMP($J,"LR","UIDHELP",(K+J))),"^",2)
  1.  . . . I (K+J)>M S M=K+J
  1.  . . W !
  1.  . W ! S DIR(0)="NO^1:"_$S(M>500:500,1:M),DIR("A")="Select UID"
  1.  . D ^DIR
  1.  . W @IOF
  1.  . I $D(DUOUT) D STOP^LRVR Q
  1.  . I '$D(DIRUT),Y D
  1.  . . S LRUID=$P(^TMP($J,"LR","UIDHELP",Y),"^")
  1.  . . D STOP^LRVR
  1.  K ^TMP($J,"LR","UIDHELP")
  1.  Q LRUID
  1.  ;
  1.  ;
  1. NEXT ; Retrieve next UID in xref.
  1.  N LRUIDX,LRQUIT
  1.  S LRQUIT=0 ; Set flag
  1.  S LRUIDX=$G(LRUID) ; Define if undefined
  1.  F  S LRUIDX=$O(^LAH(LRLL,1,"U",LRUIDX)) Q:LRUIDX=""  D  Q:LRQUIT
  1.  . N LRUID
  1.  . S LRUID=LRUIDX
  1.  . D UID
  1.  . I LRUID'="" S LRQUIT=1 ; Found a UID from this accession area.
  1.  S LRUID=LRUIDX
  1.  Q
  1.  ;
  1.  ;
  1. UID ; Setup accession variables for a given UID.
  1.  ; UID selected must be from same subscript as profile accession area.
  1.  N X
  1.  S X=$Q(^LRO(68,"C",LRUID))
  1.  I $QS(X,3)'=LRUID S (LRAD,LRAN)=0,LRUID="" Q
  1.  I 'LRANYAA,$QS(X,4)'=LRAA S (LRAD,LRAN)=0,LRUID="" Q
  1.  I $P($G(^LRO(68,LRAA,0)),"^",2)'=$P($G(^LRO(68,$QS(X,4),0)),"^",2) S (LRAD,LRAN)=0,LRUID="" Q
  1.  S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
  1.  Q
  1.  ;
  1.  ;
  1. BLDHELP(LRSD,LRLL,LRPROF) ; Build list of UID's
  1.  ; Input LRSD - seed value for partial lookups
  1.  ;              if null or missing then return all UID's in xref.
  1.  ;       LRLL - ien of loadlist.
  1.  ;     LRPROF - ien of profile on loadlist.
  1.  ; Only max of 500 allow to be displayed.
  1.  N I,K,LRAA,LRAD,LRAN,LRSS,X,Y
  1.  K ^TMP($J,"LR","UIDHELP")
  1.  S LRSD=$G(LRSD),LRLL=+$G(LRLL),LRPROF=+$G(LRPROF)
  1.  S LRAA=$P($G(^LRO(68.2,LRLL,10,LRPROF,0)),"^",2),LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)
  1.  S I="",K=0
  1.  F  S I=$O(^LAH(LRLL,1,"U",I)) Q:I=""!(K>500)  D
  1.  . I LRSD'="",LRSD'=$E(I,($L(I)-$L(LRSD))+1,$L(I)) Q  ; Is not a partial match
  1.  . S Y=I
  1.  . S X=$Q(^LRO(68,"C",I))
  1.  . I $QS(X,3)'=I Q  ; UID not in "C" x-reference.
  1.  . I 'LRANYAA,LRAA'=$QS(X,4) Q  ; Not in this accession area.
  1.  . S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
  1.  . I $P($G(^LRO(68,LRAA,0)),"^",2)'=LRSS Q  ; Not in subscript currently working with
  1.  . I LRAA,LRAD,LRAN S Y=Y_"^"_Y_" ["_$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^")_"]"
  1.  . E  Q
  1.  . I K=500 S Y="^Display abort - too many to list"
  1.  . S K=K+1,^TMP($J,"LR","UIDHELP",K)=Y
  1.  Q K