source: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRWLST11.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 7.2 KB
Line 
1LRWLST11 ;DALOI/CJS,RWF/FHS - ACCESSION SETUP ;July 19, 2006
2 ;;5.2;LAB SERVICE;**121,128,153,202,286,331**;Sep 27, 1994;Build 7
3 ;
4ST21 ;
5 S LRTS="",LRIX=0
6 F S LRIX=$O(LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)) Q:LRIX<1 D SET Q:LRUNQ
7 ;
8 S LRNT=$$NOW^XLFDT
9 D SCDT,SLRSS
10 ;
11COMMON ; Setup 'in common' accession if not already setup unless it will be
12 ; when tests are acessioned to the 'in common' area.
13 I +LRWLC,+LRWLC'=+LRAA,$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,0))=$G(LRDFN) D
14 . I $D(LRTSTS(LRWLC,LRUNQ,LRWLC)) Q
15 . Q:$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.1))
16 . N LRAA,LRACC,LRCDTX,LRCOMMON,LREND,LRIDT,LRNODE3,LRORDRR,LRORU3,LRQUIET,LRTJ,LRUID,X,Y
17 . S (LRQUIET,LRCOMMON)=1,LRAA=+LRWLC,LRORDRR=""
18 . S X=LRSS,LRCDTX=LRCDT
19 . N LRCDT,LRSS
20 . S LRCDT=LRCDTX,LRSS=X_U_(1+$G(LRLBLBP))
21 . D STWLN^LRWLST1 Q:$G(LREND)
22 . D ST2^LRWLST1 Q:$G(LREND)
23 . D SCDT,SLRSS
24 ;
25 Q
26 ;
27 ;
28SCDT ; Set collection, inverse and lab arrival date/times on accession
29 N FDA,LR6802,LRDIE
30 S LR6802=LRAN_","_LRAD_","_LRAA_","
31 S FDA(4,68.02,LR6802,9)=LRCDT
32 S FDA(4,68.02,LR6802,10)=LREAL
33 I '$D(LRPHSET) S FDA(4,68.02,LR6802,12)=LRNT
34 S FDA(4,68.02,LR6802,13.5)=LRIDT
35 D FILE^DIE("","FDA(4)","LRDIE(4)")
36 I $D(LRDIE(4)) D MAILALRT^LRWLST1
37 Q
38 ;
39 ;
40SLRSS ;
41 ;
42 S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)) ; change for AP
43 S H8=$S($D(LRSPEC):LRSPEC,1:X)_U_$S("CYEMSPAU"[LRSS:LRACC,1:LRACC)_U_$S(LRSS="MI":LRPRAC,1:"")_U_$S(LRSS="MI":LRLLOC,1:"")_"^^"_$S(LRSS="CH":LRPRAC,1:"")_"^"_$S(LRSS="MI":$P(LRSAMP,";",1),LRSS="CH":LRLLOC,1:"")
44 ;
45 I $S(LRSS="CH":1,LRSS="MI":1,1:0) D
46 . I $G(LRORDRR)="R",+$G(LRRSITE("RSITE")) S $P(H8,U,9)=+LRRSITE("RSITE")_";DIC(4,"
47 . I $G(LROLLOC),$G(LRORDRR)'="R" S $P(H8,U,9)=LROLLOC_";SC("
48 . S $P(H8,U,10)=$S($G(LRDUZ(2)):LRDUZ(2),1:$G(DUZ(2)))
49 ;
50 S ^LR(LRDFN,LRSS,LRIDT,0)=LRCDT_U_LREAL_"^^^"_H8
51 I $G(LRORU3)'="" S ^LR(LRDFN,LRSS,LRIDT,"ORU")=LRORU3
52 ;
53ST3 D ST4:(LRSS="MI"),LRCCOM
54 ;
55 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRPR=1
56 S LRRB=0
57 I LRDPF=2 S LRRB=$$GET1^DIQ(2,DFN_",",.101),LRRB=$S(LRRB'="":LRRB,1:0)
58 ;
59 Q:$G(LRORDR)="P"
60 ;
61 I '$D(LRTJ) D Q
62 . I $G(LRORDRR)="R",LRSS="CH",$G(LRORU3)'="",$P(LRORU3,"^")'=$P(LRORU3,"^",4) Q ; Don't print, use label from sending facility.
63 . I LRLBLBP,'$G(LRCOMMON) S LRLBL(LRAA,LRAN)=LRSN_U_LRAD_U_LRODT_U_LRRB_U_LRLLOC_U_LRACC_U_$S($D(LRORD):LRORD,1:"")
64 S I=0
65 F S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5 S LRTS=^(I,0) D Z
66 Q
67 ;
68 ;
69ST4 ;
70 S $P(^LR(LRDFN,LRSS,LRIDT,0),U,10)=$S($D(LRNT):LRNT,1:""),$P(^(0),U,8)=LRLLOC
71 ; Used to be LRSPCDSC,63.05,.9 (Word Processing field) replaces 63.05,.99
72 S:$D(LRCCOM) ^LR(LRDFN,LRSS,LRIDT,99)=LRCCOM
73 I '$D(LRPHSET) D
74 . N DA,DIE,DR
75 . S DIE="^LR("_LRDFN_",""MI"",",DA=LRIDT,DA(1)=LRDFN
76 . ;S DR=.9
77 . ;I '$G(LRQUIET) W:DR'=.9 !!,"Order comment:"
78 . S DR=.99_$S($L($G(LRGCOM)):"///"_LRGCOM,$L($G(LRCCOM)):"//"_LRCCOM,1:"")
79 . I '$G(LRQUIET) W:DR'=.99 !!,"Order comment:"
80 . D ^DIE
81 I '$G(LRQUIET),'$D(LRPHSET),'$D(LRGCOM) W !,"Description OK? Y//" D % G ST4:%["N"
82 K DR,DIC,DIE
83 Q
84 ;
85 ;
86ST5 S I("SUBSC")=$S(I("EDIT")[11.5:26,I("EDIT")[15:27,I("EDIT")[19:28,I("EDIT")[23:29,I("EDIT")[34:30,1:-1) Q:I("SUBSC")=-1
87 S I("PNTR")=$S(I("EDIT")[11.5:"^63.061A^",I("EDIT")[15:"^63.361A^",I("EDIT")[19:"^63.111A^",I("EDIT")[23:"^63.181A^",1:"^63.432A^")
88 S I("N")=1+$S($D(^LR(LRDFN,"MI",LRIDT,I("SUBSC"),0)):$P(^(0),U,4),1:0),^(0)=I("PNTR")_I("N")_U_I("N"),^(I("N"),0)=I("TEST")
89 Q
90 ;
91 ;
92SET S LRTS=LRTSTS(LRWLC,LRUNQ,LRAA,LRIX),LRIN=$P(LRTS,U,3),LRORIFN=$P(LRTS,U,4),LRTSORU=+$P(LRTS,U,6),LRTS=$P(LRTS,U,1,2),LRBACK=$P(LRTS,U,5)
93 ;
94 I '$G(LRQUIET),'$D(LRPHSET) D
95 . W !,$P(^LAB(60,+LRTS,0),U)
96 . I $D(LRSPEC),LRSPEC D
97 . . S I=$S($D(^LAB(61,+LRSPEC,0)):$P(^(0),U),1:""),J=$S($D(^LAB(62,+LRSAMP,0)):$P(^(0),U),1:"")
98 . . W ?30,J W:I'=J " ",I
99 ;
100 I '$G(LRQUIET),'$D(LRPHSET),+LRTS,$O(^LAB(60,+LRTS,7,0))>0 D
101 . N S
102 . S DIC="^LAB(60,",DA=+LRTS,DR=7
103 . D EN^DIQ H 3
104 I '$G(LRQUIET),'$D(LRPHSET),+LRTS D
105 . N S
106 . S DIC="^LAB(60,"_(+LRTS)_",3,"
107 . S DA=+$O(^LAB(60,+LRTS,3,"B",+LRSAMP,0)),DR=2
108 . I DA>0,$O(^LAB(60,+LRTS,3,DA,2,0))>0 D EN^DIQ H 3
109 ;
110 D ORUT
111 D CAP^LRWLST12
112 K LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)
113 ;
114 S ^LRO(69,LRODT,1,LRSN,2,LRIN,0)=LRTS_U_LRAD_U_LRAA_U_LRAN_"^^"_LRORIFN_"^^IP^L^^^^"_LRBACK
115 S ^LRO(69,LRODT,1,LRSN,2,"B",+LRTS,LRIN)=""
116 ;
117 ; When file 63 is enhanced to accept comments per test comments should
118 ; be put there instead of field 99.
119 I $O(^LRO(69,LRODT,1,LRSN,2,LRIN,1,0)) D
120 . I LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0) Q
121 . S X=$S($D(^LR(LRDFN,LRSS,LRIDT,1,0)):$P(^(0),"^",3),1:0),I=0
122 . F S I=$O(^LRO(69,LRODT,1,LRSN,2,LRIN,1,I)) Q:I<1 S II=^(I,0) S X=X+1,^LR(LRDFN,LRSS,LRIDT,1,X,0)=II
123 . S:X ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_X_U_X
124 ;
125RUID I $G(LRORU3)'="" D
126 . N DA,DIE,DIC,DLAYGO,DR,X,Y
127 . S DLAYGO=69
128 . S DA=LRIN,DA(1)=LRSN,DA(2)=LRODT,DIC="^LRO(69,"_DA(2)_",1,"_DA(1)_",2,"
129 . S DIE=DIC,DR="13////"_$P(LRORU3,U)_";14////"_$P(LRORU3,U,2)_";15////"_$P(LRORU3,U,3)_";16////"_$P(LRORU3,U,4)_";17////"_$P(LRORU3,U,5)
130 . D ^DIE
131 Q
132 ;
133 ;
134% R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
135 ;
136 ;
137LRCCOM ;
138 N I,LRCCOM,LRTN,X
139 S (I,LRTN,LRCCOM)=0 Q:LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0)
140 F S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I<1 I $D(^(I,0)) S X=^(0),LRCCOM=LRCCOM+1,^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X
141 F S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:'LRTN I $D(^(LRTN,0)) S X=^(0) I $P(X,"^",8),'$P(X,"^",3),$O(^(1,0)) D ;Get comments for expanded panels
142 . S I=0 F S I=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,1,I)) Q:'I I $D(^(I,0)) S X=^(0),LRCCOM=LRCCOM+1,^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X
143 S:LRCCOM ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_LRCCOM_U_LRCCOM
144 Q
145 ;
146 ;
147Z L +^LRO(69.1,LRTE)
148 S LRZ3=$S($D(^LRO(69.1,LRTE,1,0)):$P(^(0),U,3),1:0)
149Z1 S LRZ3=LRZ3+1 G:$D(^LRO(69.1,LRTE,1,LRZ3)) Z1
150 S LRZO="^LRO(69.1,"_LRTE_",1,",LRZ1="69.11P",LRZB=+LRTS,LRIFN=LRZ3
151 D Z^LRWU
152 S ^LRO(69.1,LRTE,1,LRIFN,0)=+LRTS_"^"_LRLLOC_"^"_LRRB_"^"_LRDFN_"^"_LRSN_"^"_LRTJ_"^"_LRAD_"^"_LRAA_"^"_LRAN_"^"_+LROLLOC
153 S ^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN)=LRTJ_"^"_LRAD_"^"_LRIFN,^(LRSN,LRAA,LRAN,+LRTS)=+LRTS
154 L -^LRO(69.1,LRTE)
155 Q
156 ;
157 ;
158ORUT Q:'$G(LRTSORU)!($G(LRSS)'="CH")
159 N LRTT,DLAYGO,DIC,DIE,DR,LRTST,DA,LRURG
160 S DA=LRIDT,DA(1)=LRDFN
161 S LRNLT=$$NLT^LRVER1(+LRTSORU) Q:+LRNLT<1 Q:$D(^LR(DA(1),LRSS,DA,"ORUT","B",LRNLT))
162 S DR=".35///^S X=LRNLT",DR(1)=".35"
163 S DR(1,63.04)=".35///^S X=LRNLT"
164 S DR(1,63.07)=".01///^S X=LRNLT"
165 S DIC="^LR("_DA(1)_","""_LRSS_""","
166 S DIC(0)="MNL",DIE=DIC W:$G(LRDBUG) !,LRNLT
167 D ^DIE
168 ;
169ORUT2 S LRTST=$P($G(^LAM($O(^LAM("E",LRNLT,0)),0)),U) Q:LRTST=""!('$G(LR696IEN))
170 Q:'($D(^LRO(69.6,LR696IEN,0))#2)!($D(^LRO(69.6,LR696IEN,2,"C",LRNLT)))
171 S:'$D(^LRO(69.6,LR696IEN,2,0)) ^(0)="^69.64A^"
172 S DLAYGO=69.6
173 K DIC,DIE,DA,DR,DA
174 S DA=LR696IEN
175 S LRURG="R",LRURG=$S($L($P($G(^LAB(62.05,+$P(LRTS,U,2),0)),U,4)):$P(^(0),U,4),1:LRURG)
176 S (DIE,DIC)="^LRO(69.6,",DIC(0)="LM"
177 S DR=20_"///"_LRTST_";",DR(1,69.6)="20///"_LRTST_";"
178 S DR(2,69.64)=".01///"_LRTST_";1///"_LRNLT_";4///"_LRURG_";5////160;8///"_LRNT_";9///"_LRUID
179 D ^DIE
180 Q
181 ;
182 ;
183SICA ; Check accessions 'in common' and setup reference to this accession
184 N FDA,LR6802,LRDIE,LRAA
185 S LRX=$P($G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.2)),"^"),LRAA=0
186 F S LRAA=$O(LRTSTS(LRWLC,LRUNQ,LRAA)) Q:LRAA<1 I LRWLC'=LRAA D
187 . S LR6802=LRAN_","_LRAD_","_LRAA_","
188 . S FDA(5,68.02,LR6802,15.1)=LRX
189 . D FILE^DIE("","FDA(5)","LRDIE(5)")
190 . I $D(LRDIE(5)) D MAILALRT^LRWLST1
191 Q
Note: See TracBrowser for help on using the repository browser.