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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1LRBEBA4 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ;8/10/04
2 ;;5.2;LAB SERVICE;**291,359**;Sep 27, 1994
3 ;
4GPRO(LRBEDN,LRBECDT,LRBESPC,LRBETST) ; Get the Procedure (CPT)
5 ; A qualified coder will setup the CPTs in #60. The routine look for
6 ; CPTs by specimen, then HCPCS, and lasty, by a default.
7 ;
8 S X="CH;"_LRBEDN_";1",Y=$O(^LAB(60,"C",X,0))
9 Q:+Y<0
10 S LRBETST=+Y
11PANEL ;Entry point for panel cpt
12 N X,Y,DIC,LRBEIEN,LRBENLT,LRN
13 S:$G(LRSPEC)="" LRSPEC=$G(LRBESPC)
14 S (LRI,LRBECPT)=""
15 ; #60 Specimen CPT
16SP60 D GCPT(LRBETST,LRBECDT,LRSPEC) Q:$O(LRBECPT(LRBETST,0))
17 ;HCPCS CODE
18HCPCS D
19 . S LRBECPT=$$GET1^DIQ(60,LRBETST_",","HCPCS CODE","I")
20 . I LRBECPT D
21 . . S LRBECPT=$$CPT^ICPTCOD(LRBECPT,LRBECDT)
22 . . I '$P(LRBECPT,U,7) S LRBECPT="" Q
23 . . S LRBECPT(LRBETST,$G(LRI)+1,$P(LRBECPT,U))="HCPCS CODE",LRI=$G(LRI)+1
24 ;Try file #64
25NLT Q:$O(LRBECPT(LRBETST,0)) D
26 . N I,LRBENLT,LRX,LRN,LRNM,SUFX
27 . S LRBENLT=$$GET1^DIQ(60,LRBETST_",",64,"I")
28 . Q:'LRBENLT
29 . S LRNM=$P($G(^LAM(LRBENLT,0)),U,2)
30 . S LRNM(1)=LRNM
31 . S SUFX=$P(LRNM,".",2)
32 . I $G(LRCDEF),SUFX'=LRCDEF S LRNM(2)=$P(LRNM,".",1)_"."_LRCDEF
33 . I SUFX S LRNM(3)=$P(LRNM,".",1)_"."_"0000"
34 . S I=0 F S I=$O(LRNM(I)) Q:'I Q:$O(LRBECPT(LRBETST,0)) D
35 . . S LRBENLT=$O(^LAM("C",LRNM(I)_" ",0)) Q:'LRBENLT
36 . . S LRN=0 F S LRN=$O(^LAM(LRBENLT,4,"AC","CPT",LRN)) Q:LRN<1 D
37 . . . S LRX=$G(^LAM(LRBENLT,4,LRN,0)) Q:'LRX D
38 . . . . Q:'$P(LRX,U,3)!($P(LRX,U,3)>LRBECDT)!($P(LRX,U,4)&($P(LRX,U,4)<LRBECDT))
39 . . . . S LRBECPT=+LRX
40 . . . . I '$P($$CPT^ICPTCOD(LRBECPT,LRBECDT),U,7) Q
41 . . . . S LRBECPT(LRBETST,($G(LRI)+1),LRBECPT)="WKLD CODE-"_LRNM(I),LRI=$G(LRI)+1
42 . . . . I LRI>1,LRBECPT(LRBETST,LRI,LRBECPT)=$G(LRBECPT(LRBETST,($G(LRI)-1),LRBECPT)) D
43 . . . . . S LRBECPT(LRBETST,($G(LRI)-1),LRBECPT,"COUNT")=+$G(LRBECPT(LRBETST,($G(LRI)-1),LRBECPT,"COUNT"))+1
44 . . . . . K LRBECPT(LRBETST,LRI,LRBECPT) S LRI=$G(LRI)-1
45 ;Default Site/Spec CPT
46SPCPT Q:$O(LRBECPT(LRBETST,0)) D
47 . S LRBECPT=$$GET1^DIQ(60,LRBETST_",","DEFAULT SITE/SPECIMEN CPT","E")
48 . I LRBECPT D
49 . . I '$P($$CPT^ICPTCOD(LRBECPT,LRBECDT),U,7) S LRBECPT="" Q
50 . . S LRBECPT(LRBETST,$G(LRI)+1,LRBECPT)="DEFAULT SITE/SPECIMEN CPT",LRI=$G(LRI)+1
51 Q
52 ;
53SCPT(CPT,TDAT) ; Get the CPT/HCPCS Code
54 Q $$CPT^ICPTCOD(CPT,TDAT)
55 ;
56GCPT(LRBETST,LRBECDT,LRSPEC) ; Get the CPT
57 N A,ARR,LRBEAX,LRBEIEN,LRBEAR60,X,XX
58 S LRBEIEN=LRSPEC_","_LRBETST_",",(LRI,LRBECPT)=""
59 D GETS^DIQ(60.01,LRBEIEN,"96*","I","LRBEAR60")
60 S A="" F S A=$O(LRBEAR60(60.196,A)) Q:A="" D
61 . Q:$G(LRBEAR60(60.196,A,1,"I"))=""
62 . S ARR($G(LRBEAR60(60.196,A,1,"I")))=$G(LRBEAR60(60.196,A,.01,"I"))
63 S XX=$P(LRBECDT,".",1)_"."_9999
64 S X=$O(ARR(XX),-1) I X D
65 .S LRBEAX=ARR(X)
66 .S LRBEAX=$$CPT^ICPTCOD(LRBEAX,LRBECDT)
67 .Q:'$P(LRBEAX,U,7)
68 .S LRBECPT(LRBETST,($G(LRI)+1),$P(LRBEAX,U))="SPECIMEN CPT",LRI=$G(LRI)+1
69 Q
70 ;
71UPDOR(DFN,ORITEM,ORIEN,ORDX,ORSCEI) ; Update CIDC information from OERR
72 I $G(^XTMP("LRPCELOG",0)) D
73 . N LRLNOW,LRI
74 . F S LRLNOW=$$NOW^XLFDT Q:'$D(^XTMP("LRPCELOG",3,LRLNOW))
75 . S ^XTMP("LRPCELOG",3,LRLNOW)=DFN_U_ORITEM_U_ORIEN_U_"["_ORSCEI_"]"
76 . S LRI=0 F S LRI=$O(ORDX(LRI)) Q:LRI="" D
77 . . S ^XTMP("LRPCELOG",3,LRLNOW,"ORDX",LRI)=ORDX(LRI)
78 I $S('$O(ORDX(0)):1,ORSCEI="^^^^^":1,1:0) Q "O^No Diagnosis Entered"
79 N LRBEAR,LRBEDFN,LRDFN,LRBEIEN,LRODT,LRORD,LRSN,LRBERMS,LRBETN,LRBETYP
80 N LRBEVST,LRAA,LRLLOC,LRSAMP,LRSPEC,LRSB,LRBEY
81 S LRBERMS=1,LRORD=$P(ORITEM,";",1),LRODT=$P(ORITEM,";",2)
82 S LRSN=$P(ORITEM,";",3),LRBEIEN=LRSN_","_LRODT_","
83 S (LRBEDFN,LRDFN)=$$GET1^DIQ(69.01,LRBEIEN,.01,"I")
84 S LRSAMP=$$GET1^DIQ(69.01,LRBEIEN,3,"I")
85 S LRLLOC=$$GET1^DIQ(69.01,LRBEIEN,8,"I")
86 S LRSPEC=$$GET1^DIQ(69.02,"1,"_LRBEIEN,.01,"I") S:LRSPEC="" LRSPEC=72
87 I LRORD'=$$GET1^DIQ(69.01,LRBEIEN,9.5,"I") D Q LRBERMS
88 .S LRBERMS="0^"_$$EMSG(1)
89 I DFN'=$$GET1^DIQ(63,LRBEDFN_",",.03,"I") D Q LRBERMS
90 .S LRBERMS="0^"_$$EMSG(2)
91 S LRBEVST=$P($G(^LRO(69,LRODT,1,LRSN,"PCE")),";",1) D WORK
92 Q LRBERMS
93 ;
94WORK ; Enter the updated information into file
95 N LRBEFND,LRBETNM,LRBETST,LRBEZ,LRBERES
96 S (LRBETN,LRBEFND)=0
97 F S LRBETN=$O(^LRO(69,LRODT,1,LRSN,2,LRBETN)) Q:LRBETN=""!('LRBETN) D
98 .Q:ORIEN'=$$GET1^DIQ(69.03,LRBETN_","_LRBEIEN,6,"I")
99 .S:'LRBEFND LRBEFND=1 S LRAA=""
100 .S LRBETST=$$GET1^DIQ(69.03,LRBETN_","_LRBEIEN,.01,"I")
101 .S LRBETNM=$$GET1^DIQ(60,LRBETST_",",.01,"I")
102 .S LRBEZ(LRBETN)=LRBETST_"^"_LRBETNM K LRBEAR
103 .D BLRSB(.LRSB,LRBETN_","_LRBEIEN,LRBETST,.LRBEY)
104 .D KILL(LRODT,LRSN,LRBETN),SET(DFN,.ORDX,ORSCEI)
105 .D SDG1(LRODT,LRSN,LRBETN,DFN,.LRBEAR)
106 I 'LRBEFND S LRBERMS="0^"_$$EMSG(3) Q
107 I LRBEVST'="",LRAA'="" S LRBERES=1 D BAWRK^LRBEBA(LRODT,LRSN,1,.LRBEY,.LRBEZ,"",LRBEVST,"",ORIEN)
108 Q
109 ;
110KILL(LRBEODT,LRBESN,LRBETN) ; Kill the existing DGX and SC/EI
111 N DA,DIK
112 S DA(1)=LRBETN,DA(2)=LRSN,DA(3)=LRODT
113 S DA="" F S DA=$O(^LRO(69,DA(3),1,DA(2),2,DA(1),2,DA)) Q:DA="" D
114 .S DIK="^LRO(69,"_DA(3)_","_1_","_DA(2)_","_2_","_DA(1)_","_2_","
115 .D ^DIK
116 Q
117 ;
118SET(DFN,ORDX,ORSCEI) ; Set #69 with new DGX and SC/EI
119 N LRBEA
120 S LRBEA="" F S LRBEA=$O(ORDX(LRBEA)) Q:LRBEA="" D
121 .S LRBEAR(DFN,"LRBEDGX",LRBEA,$G(ORDX(LRBEA)))="^^^"_ORSCEI
122 .S:LRBEA=1 $P(LRBEAR(DFN,"LRBEDGX",LRBEA,$G(ORDX(LRBEA))),U,11)=1
123 Q
124 ;
125SDG1(LRODT,LRSN,LRBETN,DFN,LRBEAR) ; Set the diagnois
126 ; and indicators file #69
127 N LRBEA,LRBEFIL,LRBEIEN,LRFDA,LRFDAIEN,LRERR,LRBEPDGX,LRBETNUM
128 S LRBEFIL=69.05,LRBETNUM=$O(^LRO(69,LRODT,1,LRSN,2,LRBETN,2,""),-1)+1
129 S LRBEA="" F S LRBEA=$O(LRBEAR(DFN,"LRBEDGX",LRBEA)) Q:LRBEA="" D
130 .S LRBEPDGX=""
131 .F S LRBEPDGX=$O(LRBEAR(DFN,"LRBEDGX",LRBEA,LRBEPDGX)) Q:LRBEPDGX="" D
132 ..S LRBEPTDT=$G(LRBEAR(DFN,"LRBEDGX",LRBEA,LRBEPDGX))
133 ..S LRBEIEN="+"_LRBETNUM_","_LRBETN_","_LRSN_","_LRODT_","
134 ..S LRFDAIEN(LRBETNUM)=LRBETNUM,LRFDA(99,LRBEFIL,LRBEIEN,.01)=LRBEPDGX
135 ..S:$P(LRBEPTDT,U,6)'="" LRFDA(99,LRBEFIL,LRBEIEN,1)=$P(LRBEPTDT,U,6)
136 ..S:$P(LRBEPTDT,U,10)'="" LRFDA(99,LRBEFIL,LRBEIEN,2)=$P(LRBEPTDT,U,10)
137 ..S:$P(LRBEPTDT,U,4)'="" LRFDA(99,LRBEFIL,LRBEIEN,3)=$P(LRBEPTDT,U,4)
138 ..S:$P(LRBEPTDT,U,5)'="" LRFDA(99,LRBEFIL,LRBEIEN,4)=$P(LRBEPTDT,U,5)
139 ..S:$P(LRBEPTDT,U,7)'="" LRFDA(99,LRBEFIL,LRBEIEN,5)=$P(LRBEPTDT,U,7)
140 ..S:$P(LRBEPTDT,U,8)'="" LRFDA(99,LRBEFIL,LRBEIEN,6)=$P(LRBEPTDT,U,8)
141 ..S:$P(LRBEPTDT,U,9)'="" LRFDA(99,LRBEFIL,LRBEIEN,7)=$P(LRBEPTDT,U,9)
142 ..S:$P(LRBEPTDT,U,11)=1 LRFDA(99,LRBEFIL,LRBEIEN,8)=1 ;Is Primary?
143 ..S LRBETNUM=LRBETNUM+1
144 D UPDATE^DIE("","LRFDA(99)","LRFDAIEN","LRERR")
145 Q
146 ;
147EMSG(LRBETYP) ; Return Error Message
148 N LRBEEMS,LRBETYPN
149 S:LRBETYP=1 LRBETYPN="Order Number" S:LRBETYP=2 LRBETYPN="DFN"
150 S:LRBETYP=3 LRBETYPN="Orderable Item"
151 S LRBEEMS="Possible reasons for failure is the "_LRBETYPN_" did not match."
152 Q LRBEEMS
153 ;
154BLRSB(LRSB,LRBEIENT,LRBETST,LRBEY) ; Build the LRSB global
155 N LRBESS,LRBEIDT,LRBESB,LRBEAA,LRBEAD,LRBEAN,LRBEIEN2,LRBET,NX,XX
156 S (LRAD,LRBEAD)=$$GET1^DIQ(69.03,LRBEIENT,2,"I")
157 S (LRAA,LRBEAA)=$$GET1^DIQ(69.03,LRBEIENT,3,"I") Q:LRAA=""
158 S (LRAN,LRBEAN)=$$GET1^DIQ(69.03,LRBEIENT,4,"I")
159 S LRBEIEN2=LRBEAN_","_LRBEAD_","_LRBEAA_","
160 S (LRSS,LRBESS)=$$GET1^DIQ(68,LRBEAA_",",.02,"I")
161 S (LRIDT,LRBEIDT)=$$GET1^DIQ(68.02,LRBEIEN2,13.5,"I")
162 S XX=$P($P(^LAB(60,LRBETST,0),U,5),";",2) I XX D
163 .S LRSB(XX)=$G(^LR(LRDFN,LRSS,LRIDT,XX))
164 .I LRSB(XX)="" K LRSB(XX) Q
165 .I "pending^canc"[$P(LRSB(XX),U,1) K LRSB(XX) Q
166 .S LRBEY(LRBETST,XX)=""
167 S NX=0 F S NX=$O(^LAB(60,LRBETST,2,NX)) Q:'NX D
168 .S LRBET=+^LAB(60,LRBETST,2,NX,0)
169 .S XX=$P($P(^LAB(60,LRBET,0),U,5),";",2) I XX D
170 ..S LRSB(XX)=$G(^LR(LRDFN,LRSS,LRIDT,XX))
171 ..I LRSB(XX)="" K LRSB(XX) Q
172 ..I "pending^canc"[$P(LRSB(XX),U,1) K LRSB(XX) Q
173 ..S LRBEY(LRBETST,XX)=""
174 Q
175 ;
176CHKINP(LRDFN,LRBEDAT) ; Check for Inpatient Status)
177 N VAIN,VAINDT
178 I '$G(DFN) D
179 . S DFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
180 . S LRDPF=$$GET1^DIQ(63,LRDFN_",",.02,"I")
181 I $G(LRDPF)'=2 Q 0
182 S VAINDT=LRBEDAT D INP^VADPT
183 Q $G(VAIN(1))
184 ;
185RFLX() ; Ask the Reflex Question
186 N DIR,DUOUT,DTOUT,DIRUT,Y
187 S DIR("A")="Is this a Reflex Test? (Y/N): "
188 S DIR(0)="YA" D ^DIR
189 I $D(DIRUT)!($D(DUOUT)!$D(DTOUT)) Q -1
190 Q +Y
191 ;
192DEFAULT ;Set Default diagnosis
193 N LRD,LRI,LRX,LRY,LRD
194 S (LRBEDMSG,LRDBEDGX)=""
195 S LRI=$O(^LRO(69,LRODT,1,LRSN,2,1,2,0)) Q:LRI<1
196 S LRD=$G(^LRO(69,LRODT,1,LRSN,2,1,2,LRI,0))
197 Q:'LRD
198 S LRDBEDGX=+LRD
199 S LRBEDMSG=+LRD_"^^^"_$P(LRD,U,4)_U_$P(LRD,U,5)_U_$P(LRD,U,2)
200 S LRBEDMSG=LRBEDMSG_U_$P(LRD,U,6)_U_$P(LRD,U,7)_U_$P(LRD,U,8)
201 S LRBEDMSG=LRBEDMSG_U_$P(LRD,U,3)_U_$P(LRD,U,9)
202 W:$G(LRDBUG) !,LRBEDMSG
203 Q
Note: See TracBrowser for help on using the repository browser.