source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRBEBA3.m@ 1783

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

initial load of FOIAVistA 6/30/08 version
File size: 8.4 KB
Line 
1LRBEBA3 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ;8/10/04
2 ;;5.2;LAB SERVICE;**291,359**;Sep 27, 1994
3 ;
4BLDAR(LRBEDFN,LRODT,LRSN,LRBEAR,LRBEY,LRBETEST,LRBEPAN,LRBEDEL) ; Build LRBEAR array with
5 ; CIDC information
6 N LRBEODT,LRBEIEN,LRBETST,LRBETS,LRJ,N,NX,P,X,XX,REQX,OK
7 S LRBEAR(LRBEDFN,"DSS ID")=LROOS
8 S LRBEAR(LRBEDFN,"ORDGX")="O"
9 S LRBEAR(LRBEDFN,"DOS")=LRBECDT
10 S LRBEAR(LRBEDFN,"PAT")=$G(LRBEDFN)
11 S LRBEAR(LRBEDFN,"POS")=LROOS
12 S LRBEAR(LRBEDFN,"DEL")=LRBEDEL
13 S LRBEAR(LRBEDFN,"USR")=DUZ
14 S LRBEIEN=LRSN_","_LRODT_","
15 S LRBEAR(LRBEDFN,"ORDPRO")=$$GET1^DIQ(69.01,LRBEIEN,7,"I")
16 S:'+$G(LRSAMP) LRSAMP=$$GET1^DIQ(69.01,LRBEIEN,3,"I")
17 ;reset LRBETEST, LRBEY for panel tests
18 S LRBETS="" F S LRBETS=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETS)) Q:'LRBETS D
19 .S LRJ=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETS,0))
20 .Q:($P(^LRO(69,LRODT,1,LRSN,2,LRJ,0),U,9)="CA")
21 .I $G(ORIEN),$P(^LRO(69,LRODT,1,LRSN,2,LRJ,0),U,7)'=ORIEN Q
22 .I ($G(^LAB(60,LRBETS,12))),($D(^LAB(60,LRBETS,0))#2),'$L($P($G(^LAB(60,LRBETS,0)),U,5)) S LRBEPAN(LRBETS)=""
23 .S OK=0,N=0 F S N=$O(LRBETEST(N)) Q:'N I LRBETS=+LRBETEST(N) S OK=1
24 .I 'OK S N=$O(LRBETEST(""),-1),N=N+1,LRBETEST(N)=LRBETS_U_^LAB(60,LRBETS,0),LRBETEST(N,"P")=LRBETS_U_$$NLT^LRVER1(LRBETS)
25 .S NX=0 F S NX=$O(^LAB(60,LRBETS,2,NX)) Q:'NX D
26 ..S X=+^LAB(60,LRBETS,2,NX,0)
27 ..S XX=$P($P(^LAB(60,X,0),U,5),";",2),REQX=$P(^(0),U,17)
28 ..I XX,$D(LRBESB(XX)) S P(LRBETS,XX,X)=""
29 ..I XX,$D(LRBEPAN(LRBETS)),REQX S P(LRBETS,XX,X)="R"
30 ..;if XX null, then possibly another panel
31 ..I 'XX D PARRAY(X,LRBETS,.P)
32 .;reset LRBEY array;
33 .;1st subscript is panel test; 2nd subscript is data identifier of atomic test
34 .I $D(P(LRBETS)) D
35 ..;retain original LRBEY array node if atomic test exists as a separate accession
36 ..I '$D(^LRO(68,$G(LRAA),1,$G(LRAD),1,$G(LRAN),4,LRBETS,0)) K LRBEY(LRBETS)
37 ..S XX=0 F S XX=$O(P(LRBETS,XX)) Q:'XX D
38 ...S LRBEY(LRBETS,XX)=""
39 ...S X=$O(P(LRBETS,XX,0))
40 ...I P(LRBETS,XX,X)="R" S LRBEY(LRBETS,XX,"R")=X
41 ;continue
42 S LRBETS="" F S LRBETS=$O(LRBETEST(LRBETS)) Q:LRBETS="" D
43 .S LRBETST=$P(LRBETEST(LRBETS),U,1)
44 .D BLDAR^LRBEBA2(LRBEDFN,LRODT,LRSN,LRBETS,LRSAMP,LRSPEC,LRBETST,.LRBEAR)
45 Q
46 ;
47PARRAY(XTEST,PTEST,P) ;
48 N NX,X,XX,REQX
49 S NX=0 F S NX=$O(^LAB(60,XTEST,2,NX)) Q:'NX D
50 .S X=+^LAB(60,XTEST,2,NX,0)
51 .S XX=$P($P(^LAB(60,X,0),U,5),";",2),REQX=$P(^(0),U,17)
52 .I XX,$D(LRBESB(XX)) S P(PTEST,XX,X)=""
53 .I XX,$D(LRBEPAN(PTEST)),REQX S P(PTEST,XX,X)="R"
54 Q
55 ;
56QRYADD(LRODT,LRSN,LRTS,LRBEDFN,LRBESMP,LRBESPC,LRBETS,LRBEX,LRBEXD) ; Query #69 for
57 ; default LRBEDGX and SC/EI
58 N LRBEA,LRDGX,LRDX,LRDGXD
59 S LRDGX=0
60 F S LRDGX=$O(^LRO(69,LRODT,1,LRSN,2,LRTS,2,LRDGX)) Q:LRDGX<1 D
61 .S LRDGXD=2
62 .S LRBEPTDT=$G(^LRO(69,LRODT,1,LRSN,2,LRTS,2,LRDGX,0)) Q:'LRBEPTDT
63 .S LRBEA=$P(LRBEPTDT,U,1)_"^^^"_$P(LRBEPTDT,U,4)_U_$P(LRBEPTDT,U,5)
64 .S LRBEA=LRBEA_U_$P(LRBEPTDT,U,2)_U_$P(LRBEPTDT,U,6)_U_$P(LRBEPTDT,U,8)
65 .S LRBEA=LRBEA_U_$P(LRBEPTDT,U,7)_U_$P(LRBEPTDT,U,3)
66 .I $P(LRBEPTDT,U,9)=1 S LRBEA=LRBEA_U_$P(LRBEPTDT,U,9),LRDGXD=1
67 .S LRBEX(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS,$P(LRBEA,U))=LRBEA
68 .S LRBEXD(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS,LRDGXD,$P(LRBEA,U))=LRBEA
69 Q
70 ;
71ELIG(DFN) ; Display eligibility and disabilities
72 D ELIG^VADPT W !," Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"")
73 W !," Disabilities: " F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1
74 .S LRDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),LRCNT=$P(I1,"^",2)
75 .S LRDIS=$E(LRDIS,1,55)
76 .I LRDIS]"" W ?15,LRDIS_" - "_LRCNT_"%("_$S($P(I1,"^",3):"SC",1:"NSC")_")",!
77 K LRDIS,LRCNT,I,I1,VAEL
78 Q
79 ;
80BALROW(LRODT,LRSN,LRTEST) ; CIDC LROW
81 N LRBEA,LRBEB,LRBEAT,LRBET,LRBESN,LRBETS,LRBETST,LRBEQT,LRBEOT,LRBEVAL
82 S LRBEVAL=$D(^XUSEC("PROVIDER",DUZ)) Q:'LRBEVAL
83 S LRBEVAL=$$CIDC^IBBAPI(DFN) Q:'LRBEVAL
84 I '$D(DFN) S LRBEDFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
85 S:$G(LRSN)="" LRSN=1
86 D SLROT^LRBEBA3(.LRXST,.LRTEST,.LRBEOT) S:$G(LRSS)="" LRSS="CH"
87 S LRBEAT=1,LRBEY=$$SBA^LRBEBA31(LRDFN,.LRBEX,.LRBEQT,.LRBEOT)
88 Q
89 ;
90AQ1 ; Ask question from LRORD1
91 N LRBEVAL
92 S LRBEVAL=$D(^XUSEC("PROVIDER",DUZ)) Q:'LRBEVAL
93 S LRBEVAL=$$CIDC^IBBAPI(DFN) Q:'LRBEVAL
94 K LRBEODT D DT^LRX S LRBEODT=%
95 S:$G(LRSS)="" LRSS="CH"
96 S LRBEAT=1,LRBEY=$$SBA^LRBEBA31(LRDFN,.LRBEX,.LRBEQT,.LROT)
97 Q
98 ;
99AQ2 ; from LROW2A
100 N LRBEVAL
101 S LRBEVAL=$$CIDC^IBBAPI(DFN) Q:'LRBEVAL
102 D SACC^LRBEBA2(LRODT,LRSN,LRTN,LRSSP,LRSPEC,$P(LRTEST(LRI),U,1),.LRBEX)
103 Q
104 ;
105SVST(ENUM,ETYP,LRODT,LRSN) ; Set the Encounter # in #69
106 S ^LRO(69,LRODT,1,LRSN,ETYP)=ENUM
107 Q
108 ;
109BALROR(LRORD) ; CIDC LRORD
110 N LRBEA,LRBEAT,LRBEB,LRBET,LRBESN,LRBETS,LRBETST,LRBEQT,LRBEODT
111 N LRBEOT,LRBEVAL,LRBEZ,LRBETN
112 S LRBEVAL=$D(^XUSEC("PROVIDER",DUZ)) Q:'LRBEVAL
113 S LRBEVAL=$$CIDC^IBBAPI(DFN) Q:'LRBEVAL
114 I '$D(DFN) S LRBEDFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
115 S LRBEAT=1,LRBEY=$$SBA^LRBEBA31(LRDFN,.LRBEX,.LRBEQT,.LROT)
116 Q
117 ;
118SLROT(LRXST,LRTEST,LRBEOT) ;LROT array
119 N LRBEA,LRBESMP,LRBESPC
120 S LRBESMP="" F S LRBESMP=$O(LRXST(LRBESMP)) Q:LRBESMP="" D
121 .S LRBEA="" F S LRBEA=$O(LRXST(LRBESMP,LRBEA)) Q:LRBEA="" D
122 ..S LRBESPC=$P(LRXST(LRBESMP,LRBEA),U,1)
123 ..S LRBEOT(LRBESMP,LRBESPC,LRBEA)=$P(LRTEST(LRBEA),U,1)
124 Q
125 ;
126MICRO1(LRODT,LRSN,LRTST,LRCNT) ;get CIDC data for microbiology
127 ;called from LRCAPPH1
128 N LRBETM
129 N AA,DX,DXCNT,FINAL,GOPRO,GEPRO,MOD,ORD,N,X
130 S FINAL=$$FINAL^LRBEBA3(LRODT,LRSN,LRTST)
131 I $P(FINAL,U)=0 K ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT) Q
132 ;continue if micro test completed
133 S DXCNT=+$O(^TMP("LRBEDX",$J,999),-1)
134 S LRBETM=$P($G(^LRO(69,LRODT,1,LRSN,3)),U) I 'LRBETM S LRBETM=LRODT
135 S LRBETM=$$PCETM^LRBEBAO(LRBETM)
136 S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"EVENT D/T")=LRBETM
137 S AA=$P($P(FINAL,";",2),U,4)
138 S GOPRO=$$GOPRO^LRBEBA2(LRODT,LRSN)
139 S GEPRO=$$GEPRO^LRBEBA2(AA)
140 S ^TMP("LRPXAPI",$J,"PROVIDER",1,"NAME")=GOPRO
141 S ^TMP("LRPXAPI",$J,"PROVIDER",1,"PRIMARY")=1
142 S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"ORD PROVIDER")=GOPRO
143 S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"ENC PROVIDER")=GEPRO
144 S ORD=$P($P(FINAL,";",2),U,7)
145 S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"ORD REFERENCE")=ORD
146 S ^TMP("LRBEDX",$J,"ID")=LRODT_U_LRSN
147 S N=0 F S N=$O(^LRO(69,LRODT,1,LRSN,2,LRTST,2,N)) Q:'N Q:N>4 D
148 .S X=^LRO(69,LRODT,1,LRSN,2,LRTST,2,N,0)
149 .S DXCNT=DXCNT+1,^TMP("LRBEDX",$J,DXCNT)=X
150 .I N=1 S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"DIAGNOSIS")=$P(X,U,1)
151 .I N>1 S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"DIAGNOSIS "_N)=$P(X,U,1)
152 Q
153 ;
154MICRO2(LRODT,LRSN) ;setup more CIDC data for microbiology
155 ;called from LRCAPPH1
156 N DXCNT,EI,EIX,X
157 S X=$G(^TMP("LRBEDX",$J,"ID"))
158 I ($P(X,U)'=LRODT)!($P(X,U,2)'=LRSN) Q
159 S DXCNT=+$O(^TMP("LRBEDX",$J,999),-1)
160 Q:'DXCNT
161 S DXCNT=0 F S DXCNT=$O(^TMP("LRBEDX",$J,DXCNT)) Q:'DXCNT D
162 .S X=^TMP("LRBEDX",$J,DXCNT)
163 .S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"DIAGNOSIS")=$P(X,U,1)
164 .I $P(X,U,2)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL SC")=$P(X,U,2),EIX("SC")=$G(EIX("SC"))+$P(X,U,2)
165 .I $P(X,U,3)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL CV")=$P(X,U,3),EIX("CV")=$G(EIX("CV"))+$P(X,U,3)
166 .I $P(X,U,4)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL AO")=$P(X,U,4),EIX("AO")=$G(EIX("AO"))+$P(X,U,4)
167 .I $P(X,U,5)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL IR")=$P(X,U,5),EIX("IR")=$G(EIX("IR"))+$P(X,U,5)
168 .I $P(X,U,6)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL EC")=$P(X,U,6),EIX("EC")=$G(EIX("EC"))+$P(X,U,6)
169 .I $P(X,U,7)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL MST")=$P(X,U,7),EIX("MST")=$G(EIX("MST"))+$P(X,U,7)
170 .I $P(X,U,8)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL HNC")=$P(X,U,8),EIX("HNC")=$G(EIX("HNC"))+$P(X,U,8)
171 .I $P(X,U,9) S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PRIMARY")=$P(X,U,9)
172 F EI="SC","CV","AO","IR","EC","MST","HNC" D
173 .I $G(EIX(EI))>1 S EIX(EI)=1
174 .I $G(EIX(EI))'="" S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,EI)=EIX(EI)
175 Q
176 ;
177FINAL(LRODT,LRSN,LRTST) ;is microbiology test complete/final?
178 ;called from MICRO1 only
179 ;returns 1_";"_<0-node of order>, if test completed
180 ; otherwise returns 0
181 N AA,AI,AY,NODEO,NODEA,NOKILL,RETURN,TST,TT,X
182 S RETURN=0,NODEA=""
183 S NODEO=$G(^LRO(69,LRODT,1,LRSN,2,LRTST,0))
184 S TST=$P(NODEO,U),AY=$P(NODEO,U,3),AA=$P(NODEO,U,4),AI=$P(NODEO,U,5)
185 I TST,AA,AI,AY S NODEA=$G(^LRO(68,AA,1,AY,1,AI,4,TST,0))
186 ;does complete date exist?
187 I $P(NODEA,U,5) S RETURN=1_";"_NODEO
188 I RETURN'=0 D
189 .S $P(^LRO(69,LRODT,1,LRSN,2,LRTST,0),U,12)=1
190 .S NOKILL=0
191 .S TT=0 F S TT=$O(^LRO(69,LRODT,1,LRSN,2,TT)) Q:'TT D
192 ..S NODEO=^LRO(69,LRODT,1,LRSN,2,TT,0),AA=$P(NODEO,U,4)
193 ..I AA,$P(NODEO,U,12)'=1,$P($G(^LRO(68,AA,0)),U,2)="MI" S NOKILL=1
194 .I NOKILL=0 S ^LRO(69,"AA",LRCEX,LROA)=""
195 Q RETURN
Note: See TracBrowser for help on using the repository browser.