source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRBEBA2.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: 9.4 KB
Line 
1LRBEBA2 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ;8/10/04
2 ;;5.2;LAB SERVICE;**291,359**;Sep 27, 1994
3 ;
4DG1(LRBESTG) ; Set the DG1 segment into the ^TMP
5 N LRBEDGX,LRBETNUM
6 S LRBETNUM=$O(^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",""),-1)
7 S LRBETNUM=$G(LRBETNUM)+1
8 S LRBEDGX=$P($P(LRBESTG,"|",4),"^",1)
9 S ^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",LRBETNUM)=LRBEDGX
10 Q
11ZCL(LRBESTG) ; Set the ZCL segment into the ^TMP
12 N LRBEX,LRBETNUM,LRBEIND
13 S LRBETNUM=$O(^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",""),-1)
14 S LRBEX=$P(LRBESTG,"|",3),LRBEIND=$P(LRBESTG,"|",4)
15 S $P(^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",LRBETNUM),U,LRBEX+1)=LRBEIND
16 Q
17 ;
18SDGX69(J,LRBEIEN) ; Set the diagnosis into #69
19 N LRBEDGX,LRBEFIL,LRFDA,LRFDAIEN,LRBESEQ,LRBEPTDT,LRBEIEN2
20 S LRBESEQ="",LRBEFIL=69.05
21 F S LRBESEQ=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,J,"LRBEDGX",LRBESEQ)) Q:LRBESEQ="" D
22 .S LRBEPTDT=$G(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,J,"LRBEDGX",LRBESEQ))
23 .S LRBEIEN2=LRBESEQ_","_LRBEIEN
24 .I '$D(^LRO(69,LRODT,1,LRSN,2,$P(LRBEIEN,",",1),2,"B",$P(LRBEPTDT,U,1))) S LRBEIEN2="+"_LRBEIEN2
25 .S LRFDA(99,LRBEFIL,LRBEIEN2,.01)=$P(LRBEPTDT,U,1),LRFDAIEN(LRBESEQ)=LRBESEQ
26 .S LRFDA(99,LRBEFIL,LRBEIEN2,1)=$P(LRBEPTDT,U,4) ;SC
27 .S LRFDA(99,LRBEFIL,LRBEIEN2,2)=$P(LRBEPTDT,U,8) ;CV
28 .S LRFDA(99,LRBEFIL,LRBEIEN2,3)=$P(LRBEPTDT,U,2) ;AO
29 .S LRFDA(99,LRBEFIL,LRBEIEN2,4)=$P(LRBEPTDT,U,3) ;IR
30 .S LRFDA(99,LRBEFIL,LRBEIEN2,5)=$P(LRBEPTDT,U,5) ;EC
31 .S LRFDA(99,LRBEFIL,LRBEIEN2,6)=$P(LRBEPTDT,U,6) ;MST
32 .S LRFDA(99,LRBEFIL,LRBEIEN2,7)=$P(LRBEPTDT,U,7) ;HNC
33 .S:LRBESEQ=1 LRFDA(99,LRBEFIL,LRBEIEN2,8)=1 ;Is Primary?
34 D UPDATE^DIE("","LRFDA(99)","LRFDAIEN","LRERR")
35 Q
36 ;
37GDG1(LRODT,SN,IFN) ; diagnosis and indicators back to CPRS
38 N LRBECNT,LRBEDGX,LRBESEQ,LRBEPTDT
39 S LRBECNT=2
40 S LRBESEQ=0 F S LRBESEQ=$O(^LRO(69,LRODT,1,SN,2,IFN,2,LRBESEQ)) Q:LRBESEQ<1 D
41 .S LRBEPTDT=$G(^LRO(69,LRODT,1,SN,2,IFN,2,LRBESEQ,0))
42 .Q:'$G(LRBEPTDT)
43 .S:$P(LRBEPTDT,"^",9)=1 ^TMP("LRX",$J,69,IFN,"LRBEDGX",1)=LRBEPTDT
44 .S:$P(LRBEPTDT,"^",9)'=1 ^TMP("LRX",$J,69,IFN,"LRBEDGX",LRBECNT)=LRBEPTDT,LRBECNT=LRBECNT+1
45 Q
46 ;
47SDG1(IFN,CTR,LRBEMSG) ; Setup the DG1 segment For CPRS
48 N LRBEX,LRBEDGX,LRBEIEN,LRBESEQ,LRBEPTDT,LRBEXMSG
49 S LRBESEQ="" F S LRBESEQ=$O(^TMP("LRX",$J,69,IFN,"LRBEDGX",LRBESEQ)) Q:LRBESEQ="" D
50 .S LRBEPTDT=$G(^TMP("LRX",$J,69,IFN,"LRBEDGX",LRBESEQ))
51 .S LRBEDGX=$$GET1^DIQ(80,$P(LRBEPTDT,U,1)_",",.01,"I")
52 .S LRBEXMSG=$$GET1^DIQ(80,$P(LRBEPTDT,U,1)_",",3,"I")
53 .S LRBEX=$P(LRBEPTDT,U,1)_"^"_LRBEXMSG_"^80^"_LRBEDGX_"^"_LRBEXMSG_"^ICD9"
54 .S CTR=CTR+1,@LRBEMSG@(CTR)="DG1|"_LRBESEQ_"||"_LRBEX_"|||||||||||||"
55 .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|1|"_$P(LRBEPTDT,U,4)
56 .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|2|"_$P(LRBEPTDT,U,5)
57 .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|3|"_$P(LRBEPTDT,U,2)
58 .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|4|"_$P(LRBEPTDT,U,6)
59 .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|5|"_$P(LRBEPTDT,U,7)
60 .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|6|"_$P(LRBEPTDT,U,8)
61 .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|7|"_$P(LRBEPTDT,U,3)
62 Q
63 ;
64GMOD(LRBEAA,LRBECPT) ; Get mod
65 ;input LRBECPT - ien to #81, not required
66 N LRBEMOD
67 S LRBECPT=$G(LRBECPT)
68 S LRBEMOD=$$GMOD^LRBEBA21(LRBEAA,LRBECPT)
69 Q LRBEMOD
70 ;
71GOPRO(LRODT,LRSN) ; Get the Ordering Provider
72 N X,Y,DIC,LRBEPRO
73 S LRBEPRO=$$GET1^DIQ(69.01,LRSN_","_LRODT_",",7,"I")
74 I $$GET^XUA4A72(LRBEPRO,DT)<0 S LRBEPRO=0 D
75 .S X=$$GET1^DIQ(69.9,1,617,"I")
76 .I $$GET^XUA4A72(X,DT)>0 S LRBEPRO=X
77 Q LRBEPRO
78 ;
79SACC(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,LRBEX) ; Set Accession
80 N LRBEZ
81 D CARR(.LRBEX,.LRBEZ,LRSAMP,LRSPEC,LRTSTS)
82 D SDG1^LRBEBA(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,.LRBEZ)
83 Q
84 ;
85CARR(LRBEAR,LRBEARR,LRBESAMP,LRBESPEC,LRTSTS) ; Change the array to only
86 ; the specimen that needs to go
87 N LRBEDFN,LRBETS,LRBESMP,LRBESPC
88 M LRBEARR=LRBEAR
89 I '$D(DFN) S LRBEDFN=$$GET1^DIQ(63,LRDFN,.03,"I")
90 S:$D(DFN) LRBEDFN=DFN
91 S LRBESMP=""
92 F S LRBESMP=$O(LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP)) Q:LRBESMP="" D
93 .I LRBESAMP'=LRBESMP D Q
94 ..K LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP)
95 .S LRBESPC=""
96 .F S LRBESPC=$O(LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC)) Q:LRBESPC="" D
97 ..I LRBESPEC'=LRBESPC D Q
98 ...K LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC)
99 ..S LRBETS=""
100 ..F S LRBETS=$O(LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS)) Q:LRBETS="" D
101 ...I LRBETS'=LRTSTS K LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS)
102 Q
103 ;
104BLDAR(LRBEDFN,LRODT,LRSN,LRTN,LRBESMP,LRBESPC,LRBETST,LRBEAR) ; Build array
105 ; with diagnosis and indicator info
106 K LRBEMSG,LRBESEQ,LRBEPTDT,LRBEODT,LRBEDMSG,LRDBEDGX,LRD
107 S LRBEODT=$P(LRODT,"."),LRBEPTDT=""
108 S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
109 Q:'$G(LRTN)
110 S LRBESEQ=0 F S LRBESEQ=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,2,LRBESEQ)) Q:LRBESEQ<1 D
111 . I LRBESEQ,$D(^LRO(69,LRODT,1,LRSN,2,LRTN,2,LRBESEQ,0)) S LRD=^(0) D
112 . . S LRBEMSG=+LRD_"^^^"_$P(LRD,U,4)_U_$P(LRD,U,5)_U_$P(LRD,U,2)
113 . . S LRBEMSG=LRBEMSG_U_$P(LRD,U,6)_U_$P(LRD,U,7)_U_$P(LRD,U,8)
114 . . S LRBEMSG=LRBEMSG_U_$P(LRD,U,3)_U_$P(LRD,U,9)
115 . . S LRBEDGX=+LRD
116 . S LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX)=LRBEMSG
117 ;if test has no dx, sc/ei, then find default dx, sc/ei
118 S LRBESEQ=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,2,0)) I 'LRBESEQ D
119 . D DEFAULT^LRBEBA4 Q:$G(LRBENO)
120 . Q:'$G(LRDBEDGX)
121 . S LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRDBEDGX)=LRBEDMSG
122 N LRTNX,LRI,LRTNXID
123 D BLDAR2(LRBETST,LRBETST,LRBESMP,LRBESPC)
124 S LRI=0 F S LRI=$O(^LAB(60,LRBETST,2,LRI)) Q:LRI<1 D
125 . S LRTNX=+$G(^LAB(60,LRBETST,2,LRI,0)) Q:'LRTNX
126 . S LRTNXID=$P($P(^LAB(60,LRTNX,0),U,5),";",2)
127 . I LRTNXID="" D BLDAR2(LRBETST,LRTNX,LRBESMP,LRBESPC)
128 Q
129 ;
130BLDAR2(LRBETST,XTEST,LRBESMP,LRBESPC) ;
131 N LRTNX,LRI,DGX,LRX
132 S LRI=0
133 F S LRI=$O(^LAB(60,XTEST,2,LRI)) Q:LRI<1 D
134 . S LRTNX=+$G(^LAB(60,XTEST,2,LRI,0)) Q:'LRTNX D
135 . . S DGX=0 F S DGX=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,DGX)) Q:DGX<1 D
136 . . . S LRX=$G(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,DGX))
137 . . . Q:'LRX
138 . . . S LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRTNX,DGX)=LRX
139 Q
140 ;
141STDN(LRODT,LRBESN,LRBETEST,LRBEAR1) ; Test and Data Number
142 N LRBEA,LRBEB,LRBEC,LRBED,LRBEDX,LRBEPTDT,X,Y
143 S LRBEA="" F S LRBEA=$O(LRBETEST(LRBEA)) Q:LRBEA="" D
144 .S DIC="^LRO(69,"_LRODT_","_1_","_LRBESN_","_"2,",DIC(0)="MZ"
145 .S X=$P(LRBETEST(LRBEA),U,2) D ^DIC K DIC I +Y<1 Q
146 .S LRBEB=0 F S LRBEB=$O(^LRO(69,LRODT,1,LRBESN,2,+Y,2,"B",LRBEB)) Q:LRBEB<1 D
147 ..S LRBEC=0 F S LRBEC=$O(^LRO(69,LRODT,1,LRBESN,2,+Y,2,"B",LRBEB,LRBEC)) Q:'LRBEC D
148 ...S LRBED="" F S LRBED=$O(LRBEAR1($P(LRBETEST(LRBEA),U,1),LRBED)) Q:LRBED="" D
149 ....S LRBEAR1($P(LRBETEST(LRBEA),U,1),LRBED,LRBEC)=LRBEB
150 Q
151 ;
152SOP(LRBEDFN,LRBESB,LRBEAR1,LRBEPAN,LRBEROLL) ;Outpatient Resulting
153 ; Information in CIDC Array
154 N DIC,LRBEDN,LRBESTG,LRBEDGX,LRBEEDT,LRBEEPRO,LRBEOPRO,LRBEQTY,LRBETST
155 N LRBEPOS,LRORREFN,LRBE21
156 ;LRBERES=Resend PCE date flag
157 K LRBECPT S (LRBECPT,LRBEEDT,LRBEEPRO,LRBEOPRO,LRBEQTY,LRORREFN)=""
158 S LRBEEPRO=$$GEPRO(LRAA),LRBEOPRO=$$GOPRO^LRBEBA2(LRODT,LRSN)
159 S LRBETST=0 F S LRBETST=$O(LRBEAR1(LRBETST)) Q:'LRBETST D
160 . S LRBE21=0
161 . ;process AMA/billable panel CPT codes
162 . I $D(LRBEPAN(LRBETST)) D EN^LRBEBA21(.LRBE21)
163 . ;otherwise process atomic test(s) CPT codes
164 . I 'LRBE21 D
165 . . S LRY=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
166 . . Q:'LRY
167 . . S LRY=LRY_","_LRSN_","_LRODT_","
168 . . Q:$$GET1^DIQ(69.03,LRY,10,"I")
169 . . I $G(ORIEN),$$GET1^DIQ(69.03,LRY,6,"I")'=ORIEN Q
170 . . S LRBECDT=$$GET1^DIQ(69.03,LRY,22,"I")
171 . . Q:'LRBECDT
172 . . S LRBEDN="" F S LRBEDN=$O(LRBEAR1(LRBETST,LRBEDN)) Q:LRBEDN="" D SOP2
173 . . I $D(LRBECPT)=11 S LRFDA(1,69.03,LRY,11)=1 D FILE^DIE("KS","LRFDA(1)","ERR")
174 Q
175 ;
176SOP2 ;Process atomic test CPT code
177 N OUT,LRBETSTX
178 I $G(LRBESB(LRBEDN))'="" D
179 . I $P(LRBESB(LRBEDN),U)="pending" Q
180 . I $P(LRBESB(LRBEDN),U)="canc" Q
181 . I '$G(LRBERES) Q:$P($G(LRBESB(LRBEDN)),U,13)
182 . S LRBEQTY=1
183 . D GPRO^LRBEBA4(LRBEDN,LRBECDT,LRSPEC,.LRBETSTX) I $G(LRBETSTX),$O(LRBECPT(LRBETSTX,0)) D
184 . . D GOREF^LRBEBA21(LRODT,LRSN,LRBEDN,.LRBEAR1,.LRORREFN)
185 . . S OUT=0 I $G(LRDFN),$G(LRIDT),$D(^LR(LRDFN,LRSS,LRIDT,$G(LRBEDN))) D
186 . . . ;test already sent to PCE
187 . . . I '$G(LRBERES) S OUT=$P(^LR(LRDFN,LRSS,LRIDT,$G(LRBEDN)),U,13) Q:OUT
188 . . . ;otherwise, mark it as sent to PCE
189 . . . S $P(^LR(LRDFN,LRSS,LRIDT,$G(LRBEDN)),U,13)=1
190 . . ;don't continue if test already sent to PCE and not re-sending from WORK^LRBEBA4
191 . . Q:OUT
192 . . S LRI=0 F S LRI=$O(LRBECPT(LRBETSTX,LRI)) Q:LRI<1 D
193 . . . S LRBECPT=$O(LRBECPT(LRBETSTX,LRI,0))
194 . . . S LRBEMOD=$$GMOD^LRBEBA2(LRAA,LRBECPT)
195 . . . S LRBEPOS=$$GPOS(.LRBESB,LRBEDN)
196 . . . D GDGX^LRBEBA21(LRBETST,LRBEDN,.LRBEAR,.LRBEAR1,.LRBEDGX)
197 . . . S LRBESTG=LRBECPT_U_LRBEMOD_U_$G(LRBEDGX(LRBETST,1))_U_$G(LRBEDGX(LRBETST,2))_U_$G(LRBEDGX(LRBETST,3))
198 . . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,4))_U_LRBECDT_U_LRBEEPRO_U_LRBEOPRO_U_LRBEQTY_U_LRBEPOS
199 . . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,5))_U_$G(LRBEDGX(LRBETST,6))_U_$G(LRBEDGX(LRBETST,7))
200 . . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,8))_U_LRORREFN
201 . . . I $G(LRBECPT(LRBETSTX,LRI,LRBECPT,"COUNT")) S $P(LRBESTG,U,20)=LRBECPT(LRBETSTX,LRI,LRBECPT,"COUNT")+1
202 . . . S LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBEDN)=LRBESTG
203 Q
204 ;
205GEPRO(LRBEAA) ; Provider - Responsible Official
206 N X,LRBEPRO
207 S LRBEPRO=$$GET1^DIQ(68,LRBEAA_",",.1,"I")
208 I $$GET^XUA4A72(LRBEPRO,DT)<0 S LRBEPRO=$$GET1^DIQ(69.9,1,617,"I")
209 Q LRBEPRO
210 ;
211GPOS(LRBESB,LRBEDN) ; Get the Place of Service
212 Q $P($G(LRBESB(LRBEDN)),U,9)
213 ;
214SLROT(LRXST,LRTEST,LRBEOT) ;LROT array
215 D SLROT^LRBEBA3(.LRXST,.LRTEST,.LRBEOT)
216 Q
Note: See TracBrowser for help on using the repository browser.