source: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRBEBAO.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 9.4 KB
Line 
1LRBEBAO ;DALOI/JAH/FHS - ORDERING AND RESULTING FOR OUTPATIENTS ;8/10/04
2 ;;5.2;LAB SERVICE;**291,359**;Sep 27, 1994
3 ;
4 ; This routine contains the subroutines that get the diagnosis pointers
5 ; and indicators at order entry and result verification for outpatient.
6 ;
7 ; Reference to EN^DDIOL supported by IA #10142
8 ; Reference to ^DIC supported by IA #10006
9 ; Reference to $$GET1^DIQ supported by IA #2056
10 ; Reference to ^DIR supported by IA #10026
11 ; Reference to ^ICD9 supported by IA #10082
12 ; Reference to ^DIC(9.4 supported by IA #10048
13 ; Reference to ^DIC(81.3 supported by IA #2816
14 ;
15OPORD ; Outpatient Order Entry
16 ;
17 ; Input:
18 ; LRBEDFN - Patient's DFN (#2)
19 ; LRBESMP - Sample
20 ; LRBESPC - Specimen
21 ; LRBETST - Ordered Test
22 ; LRBEDGX - Pointer to Diagnosis (#80)
23 ; LRBEAR(LRBEDFN,"DOS") - Date of Service
24 ; LRBEAR(LRBEDFN,"PAT") - Patient DFN (#2)
25 ; LRBEAR(LRBEDFN,"POS") - Place of Service
26 ; LRBEAR(LRBEDFN,"ORDGX") - Ordering or Resulting Diagnosis
27 ; LRBEAR(LRBEDFN,"USR") - User
28 ; LRBEAR(LRBEDFN,"ORDPRO") - Ordering Provider
29 ; LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX)
30 ; Piece Desc
31 ; ----- ---------------------------------
32 ; 1 - Diagnosis
33 ; 2 - Unused (blank)
34 ; 3 - Textual Description of Diagnosis
35 ; 4 - Agent Orange
36 ; 5 - Ionizing Radiation
37 ; 6 - Service Connected Indicator
38 ; 7 - Environmental Contaminamts
39 ; 8 - MST (Military Sexual Tramua)
40 ; 9 - Head and Neck Cancer
41 ; 10 - Combat Veteran
42 ;
43 ; Output:
44 ; LRBEAR1(VISIT,TST,LRBEPOV)=LRBEDGX
45 ; VISIT - Pointer to VISIT (9000010) file
46 ; TST - Ordered Test
47 ; LRBEPOV - Pointer to V POV (#9000010.07) file
48 ; LRBEDGX - Pointer to Diagnosis (#80)
49EN ;
50 D INIT
51 S SUB1="ENCOUNTER",SUB2="DX/PL",SUB3="PROVIDER"
52 S LRBEDFN="" F S LRBEDFN=$O(LRBEAR(LRBEDFN)) Q:LRBEDFN="" D
53 .S LRBETM=$S($P($G(LRBECDT),".",2):LRBECDT,$G(LRCDT):LRCDT,1:DT)
54 .S LRBETM=$$PCETM(LRBETM)
55 .S ^TMP("LRPXAPI",$J,SUB1,1,"ENC D/T")=LRBETM
56 .S ^TMP("LRPXAPI",$J,SUB1,1,"DSS ID")=LROOS
57 .S ^TMP("LRPXAPI",$J,SUB1,1,"HOS LOC")=$G(LRBEAR(LRBEDFN,"POS"))
58 .S ^TMP("LRPXAPI",$J,SUB1,1,"PATIENT")=$G(LRBEAR(LRBEDFN,"PAT"))
59 .S ^TMP("LRPXAPI",$J,SUB1,1,"SERVICE CATEGORY")="X"
60 .S ^TMP("LRPXAPI",$J,SUB1,1,"ENCOUNTER TYPE")="A"
61 .S ^TMP("LRPXAPI",$J,SUB3,1,"NAME")=$G(LRBEAR(LRBEDFN,"ORDPRO"))
62 .S ^TMP("LRPXAPI",$J,SUB3,1,"PRIMARY")=1
63 .I $G(LRBEAR(LRBEDFN,"DEL")) D
64 ..S ^TMP("LRPXAPI",$J,SUB1,1,"DELETE")=$G(LRBEAR(LRBEDFN,"DEL"))
65 .S LRBESMP=""
66 .F S LRBESMP=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP)) Q:LRBESMP="" D
67 ..S LRBESPC=""
68 ..F S LRBESPC=+$O(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC)) Q:LRBESPC<1 D
69 ...D OPWRK
70 Q
71 ;
72OPWRK ; More Outpatient Work
73 N X,XX,B,BG,N,DX,LRBEDIA
74 ;get all primary (n=1) and secondary (n=2) dx
75 S LRBETST="" F S LRBETST=$O(LRBECPT(LRBETST)) Q:'LRBETST D
76 . S LRBETNUM=0 F S LRBETNUM=$O(LRBECPT(LRBETST,LRBETNUM)) Q:LRBETNUM<1 D
77 . . S LRBEDGX=""
78 . . F S LRBEDGX=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX)) Q:LRBEDGX="" D
79 . . . S LRBEPTDT=$G(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX))
80 . . . S N=$S($P(LRBEPTDT,U,11):1,1:2),X=$P(LRBEPTDT,U,4,10)
81 . . . ;collapse indicators for same dx
82 . . . S XX=$G(DX(N,LRBEDGX))
83 . . . F B=1:1:7 I $P(XX,U,B)'=1,$P(X,U,B)'="" S $P(XX,U,B)=$P(X,U,B)
84 . . . S DX(N,LRBEDGX)=XX
85 ;set primary dx in PCE array
86 S LRBEDGX=""
87 F S LRBEDGX=$O(DX(1,LRBEDGX)) Q:LRBEDGX="" D
88 . S LRBEDIA=$G(LRBEDIA)+1,XX=DX(1,LRBEDGX)
89 . S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,"DIAGNOSIS")=LRBEDGX
90 . S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,"PRIMARY")=1
91 . F B=1:1:7 I $P(XX,U,B)'="" D
92 . . S BG=$$GETT(B)
93 . . I '$G(^TMP("LRPXAPI",$J,SUB2,LRBEDIA,BG)) S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,BG)=$P(XX,U,B)
94 . . ;collapse dx indicators into encounter node
95 . . I '$G(^TMP("LRPXAPI",$J,SUB1,1,$P(BG," ",2))) S ^TMP("LRPXAPI",$J,SUB1,1,$P(BG," ",2))=$P(XX,U,B)
96 ;set secondary dx in PCE array
97 S LRBEDGX=""
98 F S LRBEDGX=$O(DX(2,LRBEDGX)) Q:LRBEDGX="" D
99 . S LRBEDIA=$G(LRBEDIA)+1,XX=DX(2,LRBEDGX)
100 . S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,"DIAGNOSIS")=LRBEDGX
101 . F B=1:1:7 I $P(XX,U,B)'="" D
102 . . S BG=$$GETT(B)
103 . . I '$G(^TMP("LRPXAPI",$J,SUB2,LRBEDIA,BG)) S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,BG)=$P(XX,U,B)
104 . . ;collapse dx indicators into encounter node
105 . . I '$G(^TMP("LRPXAPI",$J,SUB1,1,$P(BG," ",2))) S ^TMP("LRPXAPI",$J,SUB1,1,$P(BG," ",2))=$P(XX,U,B)
106 Q
107 ;
108GETT(X) ; Indicators for ^TMP
109 I '+X Q ""
110 Q "PL "_$S(X=1:"AO",X=2:"IR",X=3:"SC",X=4:"EC",X=5:"MST",X=6:"HNC",1:"CV")
111 ;
112OPRES(LRBEAR,LRBEAR1,LRODT,LRSN,LRBEVST) ; Outpatient Final Resulting
113 ; Inputs:
114 ; LRBEDN - Data Number of Test in #63 field 400
115 ; LRBEAR(LRBEDFN,"VST") - Patient's Encounter Number #9000010
116 ; LRBEAR(LRBEDFN,"LRBEDGX",LRBEDN)
117 ; Piece Desc
118 ; 1 - Procedure (CPT)
119 ; 2 - Modifiers (Sub-delimited by "~")
120 ; 3 - Diagnosis
121 ; 4 - Diagnosis 2
122 ; 5 - Diagnosis 3
123 ; 6 - Diagnosis 4
124 ; 7 - Event D/T (DOS)
125 ; 8 - Encounter Provider
126 ; 9 - Ordering Provider
127 ; 10 - Quantity (Number of times procedure was performed)
128 ; 11 - Place of Service
129 ; Output:
130 ; LRBEAR1(VISIT,TST,LRBEPOV)=LRBEDGX
131 ; VISIT - Pointer to VISIT (9000010) file
132 ; TST - Ordered Test
133 ; LRBEPOV - Pointer to V POV (#9000010.07) file
134 ; LRBEDGX - Pointer to Diagnosis (#80)
135 ;
136 D INIT
137 N LRSWSTAT,LRSWDATE
138 S LRSWSTAT=$$SWSTAT^IBBAPI
139 S LRSWDATE=+$P(LRSWSTAT,U,2)
140 S LRSWSTAT=+$P(LRSWSTAT,U)
141 S SUB1="PROCEDURE"
142 I '$G(LRDBEDGX) D
143 . N LRX
144 . S (LRDBEDGX,LRX)=0
145 . F S LRX=$O(^LRO(69,LRODT,1,LRSN,2,LRX)) Q:LRX<1!($G(LRDBEDGX)) D
146 . . ;set a default diagnosis and sc/ei indicators
147 . . I $G(^LRO(69,LRODT,1,LRSN,2,LRX,2,1,0)) S LRDBEDGX=+^(0)
148 S LRBEDFN="" F S LRBEDFN=$O(LRBEAR(LRBEDFN)) Q:LRBEDFN="" D
149 . S LRI=0 F S LRI=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRI)) Q:LRI<1 D
150 . . D OPWRK2
151 ;microbiology results sent to PCE in LRCAPPH1
152 I $P($G(^LRO(68,$G(LRAA),0)),U,2)'="MI" D SEND
153 Q
154SEND ; Send if procedure is defined
155 N LRLNOW,LRVX,PXALOOK,PXUCV
156 I '$G(^TMP("LRPXAPI",$J,"PROCEDURE",1,"PROCEDURE")) G END
157 I $G(^XTMP("LRPCELOG",0)) D
158 . F S LRLNOW=$$NOW^XLFDT Q:'$D(^XTMP("LRPCELOG",1,LRLNOW))
159 . N LRACCX,LRUIDX
160 . S LRACCX=$G(LRACC),LRUIDX=$G(LRUID)
161 . M ^XTMP("LRPCELOG",2,LRLNOW)=^TMP("LRPXAPI",$J)
162 . S ^XTMP("LRPCELOG",2,LRLNOW,0)=LRACCX_U_LRUIDX
163 S LRVX=$$DATA2PCE^PXAPI(INROOT,LRPKG,SRC,.LRBEVSIT,USR,ERRDIS)
164 I $D(^XTMP("LRPCELOG",2,+$G(LRLNOW),0)) D
165 . S $P(^XTMP("LRPCELOG",2,+$G(LRLNOW),0),U,3,4)=LRVX_U_LRBEVSIT
166 . M ^XTMP("LRPCELOG",2,LRLNOW)=^TMP("LRPXAPI",$J)
167 I $G(LRBEVSIT) D SVST^LRBEBA3(LRBEVSIT,"PCE",LRODT,LRSN)
168END K ^TMP("LRPXAPI",$J),LRBETNUM
169 Q
170 ;
171OPWRK2 ; Outpatient Work Two
172 K LRBEPTDT
173 S LRBEDN=0 F S LRBEDN=+$O(LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBEDN)) Q:LRBEDN<1 D OPWRK3
174 Q
175OPWRK3 ;
176 N JJ
177 S LRBEPTDT=$G(LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBEDN))
178 Q:'($L(LRBEPTDT))
179 I '$P(LRBEPTDT,U,3) D
180 .S $P(LRBEPTDT,U,3)=LRDBEDGX
181 .S JJ=$O(^TMP("LRPXAPI",$J,"DX/PL",99),-1)+1
182 .S ^TMP("LRPXAPI",$J,"DX/PL",JJ,"DIAGNOSIS")=LRDBEDGX
183 .I JJ=1 S ^TMP("LRPXAPI",$J,"DX/PL",JJ,"PRIMARY")=1
184 .E S ^TMP("LRPXAPI",$J,"DX/PL",JJ,"PRIMARY")=0
185 S LRBETNUM=$G(LRBETNUM)+1,LRBEIEN=LRSN_","_LRODT_","
186 I $P(LRBEPTDT,U,1)'="" D
187 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"PROCEDURE")=$P(LRBEPTDT,U,1)
188 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"QTY")=1
189 I $P(LRBEPTDT,U,2)'="" D
190 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"MODIFIERS",$P(LRBEPTDT,U,2))=""
191 I $P(LRBEPTDT,U,3)'="" D
192 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS")=$P(LRBEPTDT,U,3)
193 I $P(LRBEPTDT,U,4)'="" D
194 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 2")=$P(LRBEPTDT,U,4)
195 I $P(LRBEPTDT,U,5)'="" D
196 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 3")=$P(LRBEPTDT,U,5)
197 I $P(LRBEPTDT,U,6)'="" D
198 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 4")=$P(LRBEPTDT,U,6)
199 I $P(LRBEPTDT,U,7)'="" D
200 . N LRBETM S LRBETM=$P(LRBEPTDT,U,7)
201 . S LRBETM=$$PCETM(LRBETM)
202 . S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"EVENT D/T")=LRBETM
203 I $P(LRBEPTDT,U,8)'="" D
204 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"ENC PROVIDER")=$P(LRBEPTDT,U,8)
205 I $P(LRBEPTDT,U,9)>0 D
206 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"ORD PROVIDER")=$P(LRBEPTDT,U,9)
207 I $P(LRBEPTDT,U,10)'="" D
208 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"QTY")=$P(LRBEPTDT,U,10)
209 I $P(LRBEPTDT,U,12)'="" D
210 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 5")=$P(LRBEPTDT,U,12)
211 I $P(LRBEPTDT,U,13)'="" D
212 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 6")=$P(LRBEPTDT,U,13)
213 I $P(LRBEPTDT,U,14)'="" D
214 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 7")=$P(LRBEPTDT,U,14)
215 I $P(LRBEPTDT,U,15)'="" D
216 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 8")=$P(LRBEPTDT,U,15)
217 I $P(LRBEPTDT,U,16)'="" D
218 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"ORD REFERENCE")=$P(LRBEPTDT,U,16)
219 I LRSWSTAT,($P(LRBETM,".")'<LRSWDATE) D
220 .S ^TMP("LRPXAPI",$J,"PROCEDURE",LRBETNUM,"DEPARTMENT")=108
221 I $P(LRBEPTDT,U,20)'="" D
222 .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"QTY")=$P(LRBEPTDT,U,20)
223 I $G(^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS"))=0 K ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS")
224 Q
225 ;
226INIT ;Setup PCE variables
227 S INROOT="^TMP(""LRPXAPI"",$J)"
228 I '$G(LRPKG) D Q:'$G(LRPKG)
229 . S X="LAB SERVICE",DIC="^DIC(9.4,",DIC(0)="Z" D ^DIC
230 . I Y S LRPKG=+Y
231 S SRC="LAB DATA",USR=DUZ,(LRBETNUM,ERRDIS)=0
232 K DIC
233 Q
234PCETM(LRBETM) ;Return date/time without seconds
235 N PCETM
236 S LRBETM=$G(LRBETM)
237 Q:'LRBETM LRBETM
238 S PCETM=$E($P(LRBETM,".",2),1,4)
239 F Q:($L(PCETM)=4) S PCETM=PCETM_0
240 I PCETM>2359 S PCETM=2359
241 I $E(PCETM,3,4)>59 S PCETM=$E(PCETM,1,2)_59
242 I 'PCETM S PCETM="0001"
243 S $P(LRBETM,".",2)=PCETM
244 Q LRBETM
Note: See TracBrowser for help on using the repository browser.