source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRPHITEM.m@ 1742

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

initial load of FOIAVistA 6/30/08 version
File size: 5.9 KB
Line 
1LRPHITEM ;SLC/CJS/RWF-ITEMIZED LOGIN ;6/24/91 10:49
2 ;;5.2;LAB SERVICE;**121,198,208,202,221,262**;Sep 27, 1994
3 ;
4 S LRODT=DT,LRNT=$$NOW^XLFDT
5 ;
6V1 D FNDLOC^LRDRAW G END^LRPHITE1:LRLLOC["^"
7 I LRLLOC="" W !,"All locations" S %=2 D YN^DICN G V1:%=2!(%=0),END^LRPHITE1:%=-1
8 I $L(LRLLOC) I '$D(^LRO(69.1,"LRPH",1,LRLLOC)) W !,"Location ",LRLLOC," not found on collection list.",$C(7) G V1
9 ;
10V2 ;
11 K LRSN,LROR,LRCOM,LRTCOM,LRNOCOM
12 W !!,$C(7),"Enter Order Numbers NOT collected: " S LROR=0,LRFIRST=1 D LP1 G:X="^" END^LRPHITE1
13 ; -->Fix for 208
14 I $O(LROR(0))>0 W !,"Exceptions first." S LROR=0 D
15 . N LRLLOC,LRODT
16 . F S LROR=$O(LROR(LROR)) Q:LROR<1 D EXCEPT^LRPHITE3
17 ;
18 K LRSN,LROR,LRCOM,LRTCOM
19 W !!,"Enter Order Numbers COLLECTED: " S LRNOCOM=1,LROR="" D LP1 G:X="^" END^LRPHITE1
20 G:LRLLOC'="" E1 S LRLLOC="" F S LRLLOC=$O(^LRO(69,LRODT,1,"AC",LRLLOC)) Q:LRLLOC="" D E2
21 D LEFT G END^LRPHITE1
22 ;
23E1 ;
24 D E2,LEFT G END^LRPHITE1
25 ;
26LEFT Q:$O(LROR(0))="" W !!,"DID NOT FIND THESE ORDERS:" S I=0 F S I=$O(LROR(I)) Q:I="" W $J(LROR(I),10) W:$X>69 !
27 Q
28 ;
29E2 ;
30 N LRSTORE
31 S LROR=0
32 F S LROR=$O(LROR(LROR)) Q:LROR<1 D
33 . S LRSTORE(1)=LROR(LROR)
34 . S LRSN=0
35 . F S LRSN=$O(^LRO(69,"C",LRSTORE(1),LRODT,LRSN)) Q:LRSN="" D
36 . . I $G(^LRO(69,LRODT,1,"AC",LRLLOC,LRSN))'=1 Q
37 . . S LRSTORE=0
38 . . D P15
39 . . W !,LRLLOC," ",LRSTORE(1)
40 . . W:'$G(LRSTORE) " Not Accepted !! ",$C(7)
41 . . K LROR(LROR)
42 Q
43 ;
44 ;
45P15 ;from LROE1, LRPHEXPT
46 N LRORIFN,LRX712,LRUIDA
47 ;
48 Q:'$D(^LRO(69,LRODT,1,LRSN,1)) Q:$L($P(^(1),U,4)) S J1=^(1),LRX712=^(0)
49 S LRDFN=+LRX712 K LRDPF
50 D
51 . N LRRB
52 . D PT^LRX
53 S LROLLOC=$P(LRX712,U,9)
54 S LRTREA=+$G(VAIN(3))
55 S LRORIFN=$P(LRX712,U,11)
56 S LRNT=$$NOW^XLFDT
57 ;
58 ;S ^LRO(69,LRODT,1,LRSN,1)=$P(J1,U,1,2)_"^"_DUZ_"^"_$P(J1,U,4)_"^^"_$P(J1,U,6)_"^"_$P(J1,U,7)
59 S $P(^LRO(69,LRODT,1,LRSN,1),U,3)=DUZ
60 ;
61 S $P(^LRO(69,LRODT,1,LRSN,3),U)=LRNT,^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
62 S (LRAA,LRAD,LRAN,LRTN)=0
63 F S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:LRTN<1 D
64 . I '$D(^LRO(69,LRODT,1,LRSN,2,LRTN,0)) Q
65 . S X=^LRO(69,LRODT,1,LRSN,2,LRTN,0),LRAA=+$P(X,U,4),LRAD=+$P(X,U,3),LRAN=+$P(X,U,5),LRORIFN=$P(X,U,7)
66 . D P15A
67 . I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) D
68 . . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=LRNT
69 . . S ^LRO(68,LRAA,1,LRAD,1,"E",LRNT,LRAN)=""
70 ;
71 I +$G(LRDPF)=2 D
72 . N CONTROL
73 . S CONTROL=$S($L(LRORIFN):"SC",1:"SN")
74 . D NEW^LR7OB1(LRODT,LRSN,CONTROL,,,6)
75 ;
76 N LRX
77 S LRX=""
78 F S LRX=$O(LRUIDA(LRX)) Q:LRX="" D EN^LA7ADL(LRX)
79 ;
80 Q
81 ;
82 ;
83P15A ;
84 I $G(LRDPF)=2,$$VER^LR7OU1<3 D:LRAA OR^LRWLST S $P(^LRO(69,LRODT,1,LRSN,2,LRTN,0),U,7)=LRORIFN
85 Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
86 S $P(^LRO(69,LRODT,1,LRSN,1),U,4)="C",$P(^(1),U,8)=DUZ(2),LRRB="",$P(^LRO(69,LRODT,1,LRSN,1),U)=LRNT,^LRO(69,"AA",+$G(^(.1)),LRODT_"|"_LRSN)=""
87 S LRSTORE=1
88 ;
89 ; Save list of uid's on this order, used above to download to Lab UI.
90 N X
91 S X=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),U)
92 I $L(X) S LRUIDA(X)=""
93 Q
94 ;
95P16 ;from LRPHITE1
96 N X
97 Q:'$D(^LRO(69,LRODT,1,LRSN,1))#2
98 S LRSS=$P(^LRO(68,LRAA,0),"^",2)
99 Q:'$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LRDFN=+^(0),LRDPF=$P(^(0),U,2)
100 S LRDTM=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U),LRIDT=+$P(^(3),U,5)
101 I $S('LRIDT:1,'$D(^LR(LRDFN,LRSS,LRIDT,0))#2:1,1:0) S LRNOP=1 W !?5,"Accession Information Corrupt for this Order",!! Q
102 I $P(^LR(LRDFN,LRSS,LRIDT,0),U,3) W !,$C(7),"CAN'T DO IT. The data has been verified for accession ",$P(^(0),U,6) S LRNOP=1 Q
103SKP S $P(^LRO(69,LRODT,1,LRSN,1),U,3)=DUZ,$P(^(1),U,4)="U" G P17:'LRBATCH
104 S X=$O(LRCOM(999-LROR)),LRRND=$S($L(LRRND):LRRND,X>0:LRCOM(X,1,1),1:"")
105P17 G P18:$L(LRRND) W !,"REASON FOR NON-DRAW ON ORDER ",LROR(LROR)
106 W " ",$G(LRCCOM)
107 I $G(LREPISOD) K LREPISOD
108 S LRSAMP=1,LRSPEC=1,LREND=0 I '$L(LRRND) F D Q:$L(LRRND)!($G(LREND)) W !?5,"You must enter a reason.",!
109 . N LRCCOM,LRCCOM1,LRCCOMX D FX2^LRTSTOUT S LRRND=LRCCOM
110 Q:$G(LREND)
111P18 S $P(^LRO(69,LRODT,1,LRSN,1),U,6)=LRRND
112 D:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) OUT^LRPHITE2
113 Q
114LP1 ;from LRPHEXPT
115 N Y1
116 S LRFORD=LROR K LRCCOM,LRCOM0
117 W !,"Enter Order #(s) :",! R X:DTIME Q:(X="^"!(X="")!('$T)) W ! I (X="?"!($L(X)>80)) W !,"Enter a string of numbers separated with A ',' UP TO 80 CHARACTERS LONG ",! G LP1
118 W ! F I=1:1 S LRSN=+$P(X,",",I) Q:LRSN=0 D
119 . S Y1=$O(^LRO(69,"C",+LRSN,LRODT,0))
120 . S Y=Y1 D:Y1<1 TEXT S LRSN0=Y1 ;----->LR*5.2*182
121 . I Y1'="" S LRWD=$P(^LRO(69,LRODT,1,Y1,0),U,7) S:LRLLOC'="" Y=$S(LRWD=LRLLOC:$D(^LRO(69,LRODT,1,Y,1)),1:"") S:Y LROR=LROR+1,LROR(LROR)=+LRSN D TEXT
122198 ;
123 S LRSAMP=999-LRFORD,LRSPEC=1,LRCOM(LRSAMP,1,1)="",LRCOM(LRSAMP,1)=0
124 G LP1
125TEXT S:Y<1 Y="" W:$X>70 ! W +LRSN,$S(Y:" OK, ",1:" NOT ON LIST, ")
126 QUIT
127 ;--> LR*5.2*182
128SINGLE ;
129 N X
130 Q:$G(LREPISOD)=1
131 S LREPISOD=1
132 I '$G(LRSN) S LRSN=$G(LRSN0)
133 S LRITN=$G(LRITN,LRIX)
134 S LRRND=LRCCOM
135 Q:'$G(LRSN)
136 S $P(^LRO(69,LRODT,1,LRSN,1),U,6)=LRRND
137 S X=1+$O(^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,"A"),-1),X(1)=$P($G(^(0)),U,4)
138 S ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,X,0)="*"_$G(LRCCOM1)_":"_LRCCOM,X=X+1,X(1)=X(1)+1
139 S ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,0)="^^"_X_U_X(1)_U_DT
140 K LRSAMP,LRSPEC,LRCOM,LRCCOM
141 QUIT
142POLY ;
143 N LRTIC
144 S LRTIC=0
145 F S LRTIC=$O(^LRO(69,LRODT,1,LRSN,2,LRTIC)) Q:+LRTIC'>0 S LRITN=LRTIC D
146 . S X=1+$O(^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,"A"),-1),X(1)=$P($G(^(0)),U,4)
147 . S ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,X,0)="*"_$G(LRCCOM1)_":"_LRCCOM,X=X+1,X(1)=X(1)+1
148 . S ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,0)="^^"_X_U_X(1)_U_DT
149 K DIE,LREPISOD
150 S LRCOM0=LRCCOM
151 K LRSAMP,LRSPEC,LRCOM
152 QUIT
153 ;
154MULT ;
155 S LRSN0=0 ;--> specimen number
156 F S LRSN0=$O(^LRO(69,"C",LRSN,LRODT,LRSN0)) Q:+LRSN0'>0 D LRSN
157 QUIT
158LRSN ;
159 ;--> From LRPHITE1 when multiple tests have been cancelled
160 ; LRCCOM is still valid since only one comment per order
161 ;
162 N LRTT3
163 S LRTT3=0
164 F S LRTT3=$O(^LRO(69,LRODT,1,LRSN0,2,LRTT3)) Q:+LRTT3'>0 D
165 . Q:$P(^LRO(69,LRODT,1,LRSN0,2,LRTT3,0),U,9)'="CA"
166 . S LRTIC=0
167 . F S LRTIC=$O(^LRO(69,LRODT,1,LRSN0,2,LRTT3,1,LRTIC)) Q:+LRTIC'>0 D
168 .. Q:$D(^LRO(69,LRODT,1,LRSN0,2,LRTT3,1,LRTIC,0))
169 .. N LRITN S LRITN=LRTT3
170 .. D SINGLE
171 QUIT
Note: See TracBrowser for help on using the repository browser.