source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRVRA.m@ 1800

Last change on this file since 1800 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.4 KB
Line 
1LRVRA ;DALOI/JMC-Lab Routine Data Verification by UID ;2/12/97 11:06
2 ;;5.2;LAB SERVICE;**153,221,263**;Sep 27, 1994
3 N LRANYAA,LRUID,LRNOP
4 S LRANYAA=+$P($G(^LRO(68.2,LRLL,10,LRPROF,0)),"^",3)
5 S LRUID="" D NEXT
6 D
7 . N X
8 . S X=$S(+$P($G(^LAB(69.9,1,0)),U,7):+$P(^(0),U,7),1:1)
9 . S LRTM60=9999999-$$FMADD^XLFDT(DT,-X)
10 F D Q:LREND
11 . K LRTEST,C5,LRSET,LRLDT,DIC,LRNM,LRNG,LRDL,LRDEL,T,LRFP,LRAB,LRVER,Y,Z
12 . S LRCFL="",EAMODE=1
13 . N DIR,DIRUT,DTOUT,DUOUT,X,Y
14 . D WLN I $G(LRNOP) D NEXT Q
15 . D ^LRVR1,NEXT
16 Q
17 ;
18WLN ; Select next accession (UID) to work with.
19 W ! S LRNOP=0
20 K DIR
21 S DIR(0)="FO^1:10",DIR("A")="Unique Identifier",DIR("?")="^D LW^LRVRA"
22 I $L(LRUID) S DIR("B")=LRUID
23 D ^DIR
24 I $D(DIRUT) D STOP^LRVR S LRNOP=1 Q
25 S LRUID=Y
26 I LRUID'?1.10N S LRUID=$$UP^XLFSTR(LRUID)
27 I $L(LRUID)<10 S LRUID=$$LWP(LRUID)
28 I $L(LRUID)<10 S LRUID="" G WLN
29 D UID
30 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D G WLN
31 . W !,"No accession on file for this UID."
32 . D NEXT
33 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)
34 S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
35 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
36 D PT^LRX W !,PNM,?30,SSN
37 W:LRCEN !,"ORDER #: ",LRCEN
38 I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",3) D
39 . N LRAA,LRAD,LRAN
40 . S LRSTATUS="C" D P15^LROE1
41 . I LRCDT<1 S LRNOP=1
42 I '$G(LRNOP),$P($G(^LRO(69,LRODT,1,LRSN,1)),U,4)'="C" D
43 . W !,"You cannot verify an accession which has not been collected.",$C(7)
44 . S LRNOP=1
45 I $G(LRNOP) D NEXT
46 Q
47 ;
48LW ; Display list of UID's available
49 N DIR,DIRUT,DUOUT,DTOUT,I,J,K,L,LREND,X,Y
50 S LREND=0
51 S K=$$BLDHELP("",LRLL,LRPROF)
52 I 'K W !,$C(7),"No results found in UID cross-reference." Q
53 S J=IOSL-6,L=K\(J*2) S:'(K#(J*2)) L=L-1
54 F I=0:1:L D Q:LREND
55 . W @IOF,$$CJ^XLFSTR("Current Unique Identifiers with Results Available",IOM),!!
56 . F K=((J*2)*I)+1:1:((J*2)*I)+J D
57 . . W ?3,$P($G(^TMP($J,"LR","UIDHELP",K)),"^",2)
58 . . W ?43,$P($G(^TMP($J,"LR","UIDHELP",(K+J))),"^",2),!
59 . W ! S DIR(0)="E" D ^DIR
60 . I $D(DIRUT) D STOP^LRVR Q
61 K ^TMP($J,"LR","UIDHELP")
62 Q
63 ;
64LWP(LRSD) ; Display list of partial UID's available
65 N DIR,DIRUT,DUOUT,DTOUT,I,J,K,L,LREND,LRUID,M,X,Y
66 S LRSD=$G(LRSD),(LREND,M)=0,LRUID=""
67 S K=$$BLDHELP(LRSD,LRLL,LRPROF)
68 I 'K W !,$C(7),"No results found in UID cross-reference." Q LRUID
69 S J=IOSL-6,L=K\(J*2) S:'(K#(J*2)) L=L-1
70 F I=0:1:L D Q:LREND
71 . W @IOF,$$CJ^XLFSTR("Current Unique Identifiers with Results Available",IOM),!!
72 . F K=((J*2)*I)+1:1:((J*2)*I)+J D
73 . . I $D(^TMP($J,"LR","UIDHELP",K)) D
74 . . . W ?3,$J(K,3),". ",$P($G(^TMP($J,"LR","UIDHELP",K)),"^",2)
75 . . . I K>M S M=K
76 . . I $D(^TMP($J,"LR","UIDHELP",K+J)) D
77 . . . W ?43,$J(K+J,3),". ",$P($G(^TMP($J,"LR","UIDHELP",(K+J))),"^",2)
78 . . . I (K+J)>M S M=K+J
79 . . W !
80 . W ! S DIR(0)="NO^1:"_$S(M>500:500,1:M),DIR("A")="Select UID"
81 . D ^DIR
82 . W @IOF
83 . I $D(DUOUT) D STOP^LRVR Q
84 . I '$D(DIRUT),Y D
85 . . S LRUID=$P(^TMP($J,"LR","UIDHELP",Y),"^")
86 . . D STOP^LRVR
87 K ^TMP($J,"LR","UIDHELP")
88 Q LRUID
89 ;
90NEXT ; Retrieve next UID in xref.
91 N LRUIDX,LRQUIT
92 S LRQUIT=0 ; Set flag
93 S LRUIDX=$G(LRUID) ; Define if undefined
94 F S LRUIDX=$O(^LAH(LRLL,1,"U",LRUIDX)) Q:LRUIDX="" D Q:LRQUIT
95 . N LRUID
96 . S LRUID=LRUIDX
97 . D UID
98 . I $L(LRUID) S LRQUIT=1 ; Found a UID from this accession area.
99 S LRUID=LRUIDX
100 Q
101 ;
102UID ; Setup accession variables for a given UID.
103 N X
104 S X=$Q(^LRO(68,"C",LRUID))
105 I $QS(X,3)'=LRUID S (LRAD,LRAN)=0,LRUID="" Q
106 I 'LRANYAA,$QS(X,4)'=LRAA S (LRAD,LRAN)=0,LRUID="" Q
107 S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
108 Q
109 ;
110BLDHELP(LRSD,LRLL,LRPROF) ; Build list of UID's
111 ; Input LRSD - seed value for partial lookups
112 ; if null or missing then return all UID's in xref.
113 ; LRLL - ien of loadlist.
114 ; LRPROF - ien of profile on loadlist.
115 ; Only max of 500 allow to be displayed.
116 N I,K,LRAA,LRAD,LRAN,X,Y
117 K ^TMP($J,"LR","UIDHELP")
118 S LRSD=$G(LRSD),LRLL=+$G(LRLL),LRPROF=+$G(LRPROF)
119 S LRAA=$P($G(^LRO(68.2,LRLL,10,LRPROF,0)),"^",2)
120 S I="",K=0
121 F S I=$O(^LAH(LRLL,1,"U",I)) Q:I=""!(K>500) D
122 . I $L(LRSD),LRSD'=$E(I,($L(I)-$L(LRSD))+1,$L(I)) Q ; Is not a partial match
123 . S Y=I
124 . S X=$Q(^LRO(68,"C",I))
125 . I $QS(X,3)'=I Q ; UID not in "C" x-reference.
126 . I 'LRANYAA,LRAA'=$QS(X,4) Q ; Not in this accession area.
127 . S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
128 . I LRAA,LRAD,LRAN S Y=Y_"^"_Y_" ["_$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^")_"]"
129 . E Q
130 . I K=500 S Y="^Display abort - too many to list"
131 . S K=K+1,^TMP($J,"LR","UIDHELP",K)=Y
132 Q K
Note: See TracBrowser for help on using the repository browser.