source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRGP1.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: 3.6 KB
Line 
1LRGP1 ;DALOI/CJS/RWF - COMMON PARTS TO INSTRUMENT GROUP VERIFY/CHECK ;5/13/03 13:21
2 ;;5.2;LAB SERVICE;**112,269,286**;Sep 27, 1994
3 ;
4 N %DT,%ZIS,DIC,I,J
5 ;
6 S LRWT="",LREND=0
7 S LRTM60=9999999-$$HTFM^XLFDT($H-$P($G(^LAB(69.9,1,0)),U,7),1)
8 ;
9 S DIC="^LRO(68.2,",DIC(0)="AEMZQ" D ^DIC
10 I Y<1 D LREND Q
11 S LRLL=+Y,LRWT=$P(Y(0),U,8),LRMAXCUP=$P(Y(0),U,4)
12 ;
13 S LRPROF=$O(^LRO(68.2,LRLL,10,0))
14 I LRPROF<1 W !,"No profile defined." D LREND Q
15 ; If multiple profile then ask which profile
16 S B=$O(^LRO(68.2,LRLL,10,LRPROF))
17 I B>0 S DIC="^LRO(68.2,"_LRLL_",10," D ^DIC G LREND:Y<1 S LRPROF=+Y
18 S LRPANEL=$P(^LRO(68.2,LRLL,10,LRPROF,0),U,1),LRLIST=$O(^LRO(68.2,LRLL,1,LRPROF,1,0))
19 ;
20 W !
21 ;
22 ; Select performing laboratory to use
23 I '$D(LRGVP) D
24 . N X,LRX
25 . S X=$P(^LRO(68.2,LRLL,10,LRPROF,0),"^",5)
26 . S LRX=$$SELPL^LRVERA($S(X:X,1:DUZ(2)))
27 . I LRX<1 D LREND Q
28 . I LRX,LRX'=DUZ(2) S LRDUZ(2)=LRX
29 ;
30 D EXPLODE
31 I $O(LRVTS(0))<1 D LREND Q
32 ;
33 S I=0
34 F 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)
35 ;
36 K LRAA
37 I $L($P(^LRO(68.2,LRLL,10,LRPROF,0),U,2)) S LRAA=$P(^(0),U,2),LRNAME=$P(^LRO(68,LRAA,0),U,1)
38 ;
39 I '$D(LRAA) D Q:LRAA<1
40 . S DIC="^LRO(68,",DIC(0)="AEMOQ"
41 . D ^DIC
42 . S LRAA=+Y,LRNAME=$P(Y,U,2)
43 . I LRAA<1 D LREND
44 I $P(LRPARAM,U,14),$P($G(^LRO(68,LRAA,0)),U,16) D AUTO^LRCAPV
45 I LREND Q
46 ;
47 ; If "VERIFY BY" field empty then ask user
48 I LRWT="" D Q:LREND
49 . N DA,DIR,DIRUT,DTOUT,DUOUT,X,Y
50 . S DIR(0)="68.2,.08"
51 . D ^DIR
52 . I $D(DIRUT) D LREND Q
53 . S LRWT=Y
54 ;
55 D ACC:LRWT="A",TRAY:LRWT="T",MACHSQ:LRWT="M",WRKLST:LRWT="W"
56 Q
57 ;
58 ;
59LREND ;
60 S LREND=1
61 Q
62 ;
63 ;
64ACC ; Select accession date to verify
65 ;
66 N %DT,LRLAN
67 ;
68 S LRVBY=1
69 ; Only ask if verifying, not group printing (LRGP)
70 I '$D(LRGVP) D
71 . S LRVBY=$$SELBY^LRWU4("Verify by")
72 . I LRVBY=0 D LREND
73 I LREND Q
74 I LRVBY=2 Q
75 ;
76 ; Select accession date
77 D ADATE^LRWU
78 I LREND Q
79 ;
80 ; Select starting and ending accession numbers
81 D LRAN^LRWU3
82 I LREND Q
83 S LRFAN=LRFAN-1,LRLIX=LRLAN
84 Q
85 ;
86 ;
87TRAY ; Select starting and ending tray/cup
88 ;
89 N DIR,DIRUT,DTOUT,DUOUT,X,Y
90 ;
91 ; Find existing first and last trays on loadlist
92 S LRFTRAY=$O(^LRO(68.2,LRLL,1,0))
93 I 'LRFTRAY S LRFTRAY=1
94 S LRLTRAY=$O(^LRO(68.2,LRLL,1,""),-1)
95 I 'LRLTRAY S LRLTRAY=LRFTRAY
96 ;
97 ; Find existing first and last cups on loadlist
98 S LRFCUP=$O(^LRO(68.2,LRLL,1,LRFTRAY,1,0))
99 I 'LRFCUP S LRFCUP=1
100 S LRLCUP=$O(^LRO(68.2,LRLL,1,LRLTRAY,1,""),-1)
101 I 'LRLCUP S LRLCUP=LRMAXCUP
102 ;
103 S DIR(0)="NO^1:9999999:0",DIR("A")="Starting tray",DIR("B")=1
104 D ^DIR
105 I $D(DIRUT) D LREND Q
106 S LRFTRAY=Y
107 ;
108 S DIR(0)="NO^1:9999999:0",DIR("A")="Starting cup",DIR("B")=1
109 D ^DIR
110 I $D(DIRUT) D LREND Q
111 S LRFCUP=Y
112 ;
113 S DIR(0)="NO^"_LRFTRAY_":"_LRLTRAY_":0",DIR("A")="Ending tray",DIR("B")=LRLTRAY
114 D ^DIR
115 I $D(DIRUT) D LREND Q
116 S LRLTRAY=Y
117 ;
118 S DIR(0)="NO^"_LRFCUP_":"_LRLCUP_":0",DIR("A")="Ending cup",DIR("B")=LRLCUP
119 D ^DIR
120 I $D(DIRUT) D LREND Q
121 S LRLCUP=Y
122 ;
123 Q
124 ;
125 ;
126MACHSQ ; Select starting and ending machine sequence
127 ;
128 N DIR,DIRUT,DTOUT,DUOUT,X,Y
129 ;
130 S DIR(0)="NO^1:9999999:0",DIR("A")="Starting sequence number",DIR("B")=1
131 D ^DIR
132 I $D(DIRUT) D LREND Q
133 S LRSQ=Y
134 ;
135 S DIR(0)="NO^1:9999999:0",DIR("A")="Ending sequence number",DIR("B")=9999999
136 D ^DIR
137 I $D(DIRUT) D LREND Q
138 S LRESEQ=Y
139 Q
140 ;
141 ;
142WRKLST ; Select starting and ending worklist numbers
143 ;
144 N DIR,DIRUT,DTOUT,DUOUT,X,Y
145 ;
146 S DIR(0)="NO^1:9999999:0",DIR("A")="Starting worklist number",DIR("B")=1
147 D ^DIR
148 I $D(DIRUT) D LREND Q
149 S LRCUP=Y
150 ;
151 S DIR(0)="NO^1:9999999:0",DIR("A")="Ending worklist number",DIR("B")=9999999
152 D ^DIR
153 I $D(DIRUT) D LREND Q
154 S LRECUP=Y
155 Q
156 ;
157 ;
158EXPLODE ;
159 K LRORD
160 D EXPLODE^LRGP2
161 Q
Note: See TracBrowser for help on using the repository browser.