source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR32.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 8.1 KB
Line 
1ORWDLR32 ; SLC/KCM/REV/JDL - Lab Calls 6/28/2002
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141,215,250**;Dec 17, 1997;Build 1
3 ;
4 ; DBIA 2263 GETLST^XPAR ^TMP($J,"WC")
5 ;
6DEF(LST,ALOC,ADIV) ; procedure
7 ; For Event Delay Order
8 ; ALOC: Delay Event's default location
9 ; ADIV: Delay Event's default division
10 ; get dialog definition specific to lab
11 S ILST=0
12 S LST($$NXT)="~ShortList" D SHORT
13 S LST($$NXT)="~Lab Collection Times" D LCOLLTM
14 S LST($$NXT)="~Ward Collection Times" D WCOLLTM
15 S LST($$NXT)="~Send Patient Times" D SENDTM
16 S LST($$NXT)="~Collection Types" D COLLTYP
17 S LST($$NXT)="~Default Urgency" D URGENCY
18 S LST($$NXT)="~Schedules" D SCHED
19 S LST($$NXT)="~Common" D COMMON
20 Q
21SHORT ; from DEF, get short list of lab quick orders
22 N I,ORTMP,ORDG,A
23 S I=$O(^ORD(100.98,"B","LAB",0)) ; get IEN of parent lab
24 D DG^ORCHANG1(I,"BILD",.ORDG) ; find members groups for parent lab
25 S I=0
26 F S I=$O(ORDG(I)) Q:'I D ; loop through list of members groups
27 . D GETQLST^ORWDXQ(.ORTMP,I,"Q") ;get quick order of each members groups
28 . S A=0 F S A=$O(ORTMP(A)) Q:'A D ; loop through returned quick orders and
29 . . S LST($$NXT)="i"_ORTMP(A) ; move quick orders to display list
30 . K ORTMP ; clean up for next members groups of quick orders
31 Q
32LCOLLTM ; get collection times
33 N TDAY,TMRW,IGNOR,CNT,ICTM,ORCTM,DOW,AMPM,DAY,TIME,TXDT
34 S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H,TDAY("TX")="T"
35 M TMRW=TDAY D INCDATE(.TMRW)
36 I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D
37 . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q")
38 . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q")
39 . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q")
40 . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q")
41 . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q")
42 . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q")
43 . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q")
44 . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q")
45 . S CNT=0 F Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0)))) D Q:CNT>6
46 . . D INCDATE(.TDAY) S CNT=CNT+1
47 . S CNT=0 F Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0)))) D Q:CNT>6
48 . . D INCDATE(.TMRW) S CNT=CNT+1
49 I $G(ADIV) D GETLST^XPAR(.ORCTM,ADIV_";DIC(4,^SYS","LR PHLEBOTOMY COLLECTION","Q")
50 E D GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q")
51 ;S DUZ(2)=TMPDIV
52 S LST($$NXT)="iLNEXT^Next scheduled lab collection"
53 S ICTM=0 F S ICTM=$O(ORCTM(ICTM)) Q:'ICTM D
54 . I $P(ORCTM(ICTM),U)>$P($H,",",2) D
55 . . S TXDT=TDAY("TX")
56 . . I +TDAY("H")=+$H S DAY="Today"
57 . . I TDAY("H")-$H=1 S DAY="Tomorrow"
58 . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW"))
59 . E D
60 . . S TXDT=TMRW("TX")
61 . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow")
62 . S AMPM=$S($P(ORCTM(ICTM),U,2)>1159:"PM",1:"AM")
63 . S TXDT=TXDT_"@"_$P(ORCTM(ICTM),"^",2)
64 . S TIME=$P(ORCTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4)
65 . S LST($$NXT)="iL"_TXDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")"
66 . S ^TMP($J,"WC",ILST)="iW"_TXDT_U_TIME_" "_AMPM_" ("_DAY_") Ward collect" ;DBIA 2263
67 ; D NOW^%DTC
68 ;S LST($$NXT)="iWNOW^Now (Collect on ward)"
69 S LST($$NXT)="iLO^Future"
70 Q
71WCOLLTM ; get Ward Collect times
72 S I=""
73 F S I=$O(^TMP($J,"WC",I)) Q:I="" D
74 . S LST($$NXT)=^TMP($J,"WC",I)
75 S LST($$NXT)="iWNOW^Now (Collect on ward)"
76 ;S LST($$NXT)="iWO^Other"
77 K ^TMP($J,"WC")
78 Q
79SENDTM ; get send patient times
80 ;N X,X1,X2
81 S LST($$NXT)="iLT^Today"
82 ;S X1=DT,X2=1 D C^%DTC
83 S LST($$NXT)="iLT+1^Tomorrow"
84 ;S LST($$NXT)="iLO^Other"
85 Q
86COLLTYP ; Collection Types in effect for this division
87 N Y S Y=""
88 S LST($$NXT)="iLC^Lab Collect"
89 S LST($$NXT)="iWC^Ward Collect"
90 S LST($$NXT)="iSP^Send Patient to Lab"
91 I +$$ON^LR7OV4(DUZ(2)) S LST($$NXT)="iI^Immediate Collect"
92 S:$G(ALOC) Y=$$GET^XPAR("ALL^"_ALOC_";SC(","LR DEFAULT TYPE QUICK")
93 I $L(Y) S LST($$NXT)="d"_Y
94 Q
95INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE
96 N X,X1,X2,%H
97 S X1=ADATE,X2=1 D C^%DTC S ADATE=X
98 S ADATE("H")=ADATE("H")+1
99 S ADATE("DOW")=ADATE("H")#7
100 S ADATE("TX")="T+"_($P(ADATE("TX"),"+",2)+1)
101 Q
102DOWNAME(DOW) ; function
103 ; Returns Day of Week name (DOW should be $H#7)
104 I DOW=0 Q "Thursday"
105 I DOW=1 Q "Friday"
106 I DOW=2 Q "Saturday"
107 I DOW=3 Q "Sunday"
108 I DOW=4 Q "Monday"
109 I DOW=5 Q "Tuesday"
110 I DOW=6 Q "Wednesday"
111 Q ""
112URGENCY ; return default urgency for lab
113 N URG
114 S URG=$$DEFURG^LR7OR3
115 S LST($$NXT)="i"_URG_U_$P(^LAB(62.05,URG,0),U,1)
116 S LST($$NXT)="d"_URG_U_$P(^LAB(62.05,URG,0),U,1)
117 Q
118SCHED ; return list of schedules available for lab tests
119 N X,X0,IEN
120 S X="" F S X=$O(^PS(51.1,"APLR",X)) Q:X="" S IEN=$O(^(X,0)) I IEN D
121 . S X0=$G(^PS(51.1,IEN,0)) Q:X0=""
122 . I (($P(X0,U,5)="C")!($P(X0,U,5)="D")),(+$P(X0,U,3)=0) Q
123 . S LST($$NXT)="i"_IEN_U_X_U_$P(X0,U,5)_U_$P(X0,U,3)
124 . I X="ONE TIME" S LST($$NXT)="d"_IEN_U_X
125 Q
126COMMON ; return list of commonly ordered lab tests
127 N ORLST,IEN,I
128 D GETLST^XPAR(.ORLST,"ALL","ORWD COMMON LAB INPT") ;DBIA 2263
129 S I=0 F S I=$O(ORLST(I)) Q:'I D
130 . S IEN=$P(ORLST(I),U,2)
131 . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1)
132 Q
133LOAD(LST,TESTID) ; procedure
134 ; Return sample, specimen, & urgency info about a lab test
135 N I,J,X,X1,X4,ORY,ORLABID,ILST,PARAM
136 S ILST=0
137 S LST($$NXT)="~Test Name"
138 S LST($$NXT)="d"_$P(^ORD(101.43,TESTID,0),U,1),ORLABID=$P(^(0),U,2)
139 S LST($$NXT)="~Item ID"
140 S LST($$NXT)="d"_+ORLABID
141 S X=$P(ORLABID,";",1),X1=$P(ORLABID,";",2)
142 I $E(X1,1,4)="99VB" S X1=$O(^LAB(60,"B","VBECS "_$P(^ORD(101.43,TESTID,0),"^"),0)) Q:'X1 S X=X1
143 S X4=$P($G(^LAB(60,X,0)),U,4)
144 S LST(ILST)=LST(ILST)_U_X4
145 I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage"
146 S I=0 F S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I S LST($$NXT)="t"_^(I,0)
147 S TESTID=+$P(^ORD(101.43,TESTID,0),U,2)
148 D TEST^LR7OR3(TESTID,.ORY)
149 S PARAM="" F S PARAM=$O(ORY(PARAM)) Q:PARAM="" D
150 . S LST($$NXT)="~"_PARAM
151 . I PARAM="ReqCom" D
152 . . S LST($$NXT)="d"_$G(ORY("ReqCom")) Q
153 . I PARAM="Default CollSamp" D
154 . . S LST($$NXT)="d"_$G(ORY("Default CollSamp")) Q
155 . I PARAM="Unique CollSamp" D
156 . . S LST($$NXT)="d"_$G(ORY("Unique CollSamp")) Q
157 . I PARAM="Default Urgency" D
158 . . S LST($$NXT)="d"_$G(ORY("Default Urgency")) Q
159 . I PARAM="Lab CollSamp" D
160 . . S LST($$NXT)="d"_$G(ORY("Lab CollSamp")) Q
161 . I $D(ORY(PARAM))>1 S I=0 F S I=$O(ORY(PARAM,I)) Q:'I D
162 . . I PARAM="Specimens" S LST($$NXT)="i"_ORY(PARAM,I) Q
163 . . I PARAM="Urgencies" S LST($$NXT)="i"_ORY(PARAM,I) Q
164 . . I PARAM="GenWardInstructions" S LST($$NXT)="t"_ORY(PARAM,I,0) Q
165 . . S LST($$NXT)="i"_I_U_ORY(PARAM,I)
166 . . I PARAM="CollSamp" D
167 . . . I $G(ORY("Lab CollSamp")) S $P(LST(ILST),U,8)=1
168 . . . S X=+$P(ORY(PARAM,I),U,3)
169 . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1)
170 . . I $D(ORY(PARAM,I,"WP")) S J=0 F S J=$O(ORY(PARAM,I,"WP",J)) Q:'J D
171 . . . S LST($$NXT)="t"_ORY(PARAM,I,"WP",J,0)
172 Q
173ALLSAMP(LST) ; procedure
174 ; returns all collection samples
175 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName
176 N SMP,SPC,ILST,IEN,X,X0
177 S ILST=0,LST($$NXT)="~CollSamp"
178 S SMP="" F S SMP=$O(^LAB(62,"B",SMP)) Q:SMP="" D
179 . S IEN=0 F S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN D
180 . . S X0=^LAB(62,IEN,0)
181 . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7)
182 . . I $P(X0,U,2) D
183 . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1)
184 . . . S SPC($P(X,U,4))=$P(X,U,10)
185 . . S LST($$NXT)=X
186 S LST($$NXT)="~Specimens"
187 S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC)
188 Q
189ONESAMP(LST,IEN) ;Return data for one colelction sample
190 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName
191 N SPC,ILST,X,X0
192 Q:+$G(IEN)=0
193 S ILST=0,LST($$NXT)="~CollSamp"
194 S X0=^LAB(62,IEN,0)
195 S X="i1"_U_IEN_U_$P(X0,U,1)_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7)
196 I $P(X0,U,2) D
197 . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1)
198 . S SPC($P(X,U,4))=$P(X,U,10)
199 S LST($$NXT)=X
200 S LST($$NXT)="~Specimens"
201 S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC)
202 Q
203ONESPEC(LST,IEN) ;return one specimen
204 Q:(+$G(IEN)=0)!('$D(^LAB(61,IEN,0)))
205 S LST=IEN_U_$P(^LAB(61,IEN,0),U,1)
206 Q
207ABBSPEC(LST) ; procedure
208 ; returns specimens with abbreviation (uses 'E' xref)
209 N X,IEN,ILST S ILST=0
210 S X="" F S X=$O(^LAB(61,"E",X)) Q:X="" S IEN=$O(^(X,0)) D
211 . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1)
212 Q
213NXT() ; called by TESTINFO, increments ILST
214 S ILST=ILST+1
215 Q ILST
216 ;
Note: See TracBrowser for help on using the repository browser.