source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRWU4.m@ 1006

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

initial load of WorldVistAEHR

File size: 4.7 KB
Line 
1LRWU4 ;DALOI/RWF - READ ACCESSION ;2/7/91 14:49
2 ;;5.2;LAB SERVICE;**128,153,201,271**;Sep 27, 1994
3 ;
4 ; Reference to ^DISV("LRACC") global supported by DBIA #510
5 ;
6 ; Variable LRVBY set/used by routine LRVER to determine if user
7 ; verifying by accession or UID.
8 ; If variable LRVBY evaluates to 1 then only select by accession.
9 ; If LRVBY<1 or undefined then lookup also by UID.
10 ;
11EN ;
12 N %,DIC,DIR,DIRUT,DUOUT,DTOUT,LRQUIT,LRX
13 ;
14 K LRNATURE
15 S U="^",DT=$$DT^XLFDT,LRQUIT=0
16 F D AA Q:LRQUIT
17 Q
18 ;
19 ;
20AA ;
21 S DIR(0)="FO^1:30",DIR("A")="Select Accession"_$S($G(LRVBY)=1:"",1:" or UID")
22 S DIR("?")="^D QUES^LRWU4"
23 D ^DIR
24 I Y=""!$D(DIRUT) D QUIT Q
25 S LRX=Y
26 ;
27 S:$L(LRX)>2 ^DISV(DUZ,"LRACC")=LRX
28 S:LRX=" " LRX=$S($D(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
29 S (LRAA,LRAD,LRAN)=0
30 ;
31 ; see if entry is UID
32 I $G(LRVBY)<1,$D(^LRO(68,"C",LRX)) D UNIV Q
33 ;
34 ; Parse and process user input.
35 S (X1,X2,X3)="",X1=$P(LRX," ",1),X2=$P(LRX," ",2),X3=$P(LRX," ",3)
36 S:X3=""&(+X2=X2) X3=X2,X2=""
37 I X1'?1A.AN D QUES Q
38 S LRAA=$O(^LRO(68,"B",X1,0))
39 I LRAA<1 D WLQUES Q:LRAA<1
40 S %=$P(^LRO(68,LRAA,0),U,14)
41 I $L(%),'$D(^XUSEC(%,DUZ)) D WLQUES Q:LRAA<1
42 ;
43 S LRX=$G(^LRO(68,LRAA,0)),LRIDIV=$S($L($P(LRX,U,19)):$P(LRX,U,19),1:"CP")
44 W !,$P(LRX,U)
45 ;
46 ; User entered only accession area identifier, no date or number
47 I X2="",X3="" D
48 . N %DT
49 . S %DT="AEP",%DT("A")=" Accession Date: ",%DT("B")="TODAY"
50 . D DATE^LRWU
51 . I $D(DUOUT) D QUIT Q
52 . I Y<1 D QUES Q
53 . S LRAD=Y
54 I LRQUIT Q
55 ;
56 ; Convert middle value to FileMan date
57 ; Adjust for monthly and quarterly formats (MM00) if user enters 4 digit
58 ; number as middle part of accession then convert to appropriate date.
59 I LRAD<1 D
60 . N %DT
61 . I X2="" S X2=DT
62 . I X2?4N D
63 . . S X2=$E(DT,1,3)_X2
64 . . I X2>DT S X2=X2-10000
65 . S %DT="EP",X=X2
66 . D ^%DT
67 . I Y>0 S LRAD=Y Q
68 . D QUES
69 I LRAD<1 Q
70 ;
71 ; Convert date entered to apropriate date for accession area transform
72 S X=$P(^LRO(68,LRAA,0),U,3)
73 S LRAD=$S("D"[X:LRAD,X="Y":$E(LRAD,1,3)_"0000","M"[X:$E(LRAD,1,5)_"00","Q"[X:$E(LRAD,1,3)_"0000"+(($E(LRAD,4,5)-1)\3*300+100),1:LRAD)
74 W:X3>0 " ",+X3
75 ;
76 I X3="",$D(LRACC) D
77 . N DIR,DIRUT,DUOUT,DTOUT,X,Y
78 . S DIR(0)="NO^1:999999",DIR("A")=" Number part of Accession"
79 . D ^DIR
80 . I Y=""!$D(DIRUT) Q
81 . S X3=Y
82 ;
83 I X3="",$D(LRACC) D QUIT Q
84 S LRAN=+X3
85 I LRAN<1,$D(LRACC) D QUES Q
86 I $D(LRACC),'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
87 . W !,"ACCESSION: ",$P(^LRO(68,LRAA,0),U,11)," ",$$FMTE^XLFDT(LRAD,"5D")," ",LRAN," DOES NOT EXIST!"
88 ;
89 S LRQUIT=1
90 Q
91 ;
92 ;
93QUIT ;
94 S (LRAN,LRAA,LRAD)=-1
95END ;
96 K X1,X2,X3,%DT,DIC,LRIDIV
97 S LRQUIT=1
98 Q
99 ;
100 ;
101UNIV ; see if entry is UID
102 N LRY
103 S LRY=$$CHECKUID(LRX)
104 I 'LRY S (LRAA,LRAD,LRAN)=0 D QUES Q
105 S LRAA=$P(LRY,"^",2),LRAD=$P(LRY,"^",3),LRAN=$P(LRY,"^",4)
106 S LRQUIT=1
107 W " (",$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^"),")"
108 Q
109 ;
110 ;
111QUES ;
112 W $C(7),!,"Enter the accession number",$S($G(LRVBY)<1:" or the unique identifier (UID)",1:""),"."
113 W !,"If entering the accession number, enter in this format:"
114 W !?5," <ACCESSION AREA> <DATE> <NUMBER>"
115 W !?5," ie. CH 0426 125 or CH 125 or CH T 125",!?5," or if it's a yearly accession area ie. MICRO 85 30173"
116 W:'$D(LRACC) !?5," or just the Accession area, or area and date."
117 W:$D(LRACC) !?5," Must include the Accession area and the final number part."
118 I $G(LRVBY)<1 W !,"If entering the UID, enter the entire 10-15 characters."
119 Q
120 ;
121WLQUES ; Ask user if acession area enter does not match any existing entries
122 N DIC,X
123 S X=X1,DIC="^LRO(68,",DIC(0)="EMOQ"
124 S DIC("S")="Q:$D(LREXMPT) S %=$P(^(0),U,14) X ""I '$L(%)"" Q:$T S %=$P(^DIC(19.1,%,0),U,1) I $D(^XUSEC(%,DUZ))"
125 W !,X
126 D ^DIC S LRAA=+Y
127 Q
128 ;
129SELBY(X1) ; Select by accession number or unique identifier (UID)
130 ; Call with X1 = message prompt
131 ; Returns Y = 0 (abort)
132 ; = 1 (accession number)
133 ; = 2 (unique identifier)
134 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
135 S X1=$G(X1,"Select UID")
136 S DIR(0)="SO^1:Accession Number;2:Unique Identifier (UID)",DIR("A")=X1,DIR("B")=1
137 D ^DIR
138 I $D(DIRUT) S Y=0
139 Q Y
140 ;
141UID(LRX,LRY) ; Lookup accession by UID
142 ; Call with LRX = message prompt
143 ; LRY = default UID to display
144 ; Returns Y = 0 (abort)
145 ; = UID
146 ;
147 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
148 ;
149 S LRX=$G(LRX,"Select UID")
150 S DIR(0)="F^10:10^K:'$D(^LRO(68,""C"",X)) X"
151 S DIR("A")=LRX,DIR("?")="Enter the full 10 character UID"
152 I $L($G(LRY)) S DIR("B")=LRY
153 D ^DIR
154 I $D(DIRUT) S Y=0
155 Q Y
156 ;
157 ;
158CHECKUID(LRX) ; Check if UID is valid, accession exists.
159 ; Call with LRX = UID to check
160 ; Returns Y = 0 (accession does not exist)
161 ; = 1 (accession exists)^area^date^number
162 ;
163 N LRY,Y
164 ;
165 S LRY=0
166 S Y=$Q(^LRO(68,"C",LRX))
167 I $QS(Y,3)=LRX,+$QS(Y,4),+$QS(Y,5),+$QS(Y,6) D
168 . I '$D(^LRO(68,+$QS(Y,4),1,+$QS(Y,5),1,+$QS(Y,6),0)) Q
169 . S LRY=1_"^"_$QS(Y,4)_"^"_$QS(Y,5)_"^"_+$QS(Y,6)
170 Q LRY
Note: See TracBrowser for help on using the repository browser.