source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRBEBA.m@ 1683

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

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1LRBEBA ;DALOI/JAH/FHS - SCI, EI, AND LRBEDGX QUESTIONS ;8/10/04
2 ;;5.2;LAB SERVICE;**291**;Sep 27, 1994
3 ;
4 ; This routine contains the questions to be asked for
5 ; Service Connected Indicator, Environmental Indicator,
6 ; and Diagnosis.
7 ;
8 ; Reference to EN^DDIOL supported by IA #10142
9 ; Reference to ^DIC supported by IA #10006
10 ; Reference to $$GET1^DIQ supported by IA #2056
11 ; Reference to ^DIR supported by IA #10026
12 ; Reference to ^ICD9 supported by IA #10082
13 ; Reference to ^DIC(9.4 supported by IA #10048
14 ;
15QUES(LRBEDFN,LRBESMP,LRBESPC,TST,DT,LRBEAR,LRBEDP) ; Start asking questions
16 N DIC,DIR,DTOUT,DUOUT,DIRUT,LRBEFMSG,LRBEST,LRBEQT,X,Y
17 S:$G(LRBEALO)="" LRBEALO=0 S (LRBEST,LRBEQT)=0
18 F D Q:LRBEQT
19 .;ensure it's active on the date of encounter
20 .;S DIC("S")="I $$STATCHK^ICDAPIU(Y,DT)"
21 .S LRBEFMSG=" ICD-9 CODE: "
22 .S DIC("A")="Select "_$S(LRBEALO=0:"Primary",1:"Secondary")_LRBEFMSG
23 .S DIC="^ICD9(",DIC(0)="AMEQZ" D ^DIC
24 .I $D(DTOUT)!($D(DUOUT)) S (LRBEST,LRBEQT)=1 K DIC,LRBEAR Q:LRBEQT
25 .I +Y<1 K DIC S LRBEQT=1 Q:LRBEQT
26 .S LRBEDGX=+Y
27 .S LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,TST,LRBEDGX)=$P(Y(0),U,1,3)
28 .S:'LRBEALO $P(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,TST,LRBEDGX),U,11)=1
29 .S LRBEALO=1 D SCI(LRBEDFN,DT,.LRBEQT) Q:LRBEQT
30 K LRBEALO
31 Q LRBEST
32 ;
33SCI(LRBEDFN,LRBECDT,LRBEQT) ; Ask the Indicator Questions
34 N DIR,DTOUT,DUOUT,DIRUT,I,LRBEA,LRBEB,LRBEBL,LRBESEG,LRBECLY,Y
35 I $D(LRBEDP(LRBEDGX)) D Q
36 .S LRBEBL=$L($G(LRBEDP(LRBEDGX)),U)
37 .S LRBEB=$P(LRBEDP(LRBEDGX),U,4,LRBEBL)
38 .S $P(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,TST,LRBEDGX),U,4,LRBEBL)=LRBEB
39 D CL^SDCO21(LRBEDFN,LRBECDT_".2359","",.LRBECLY)
40 S LRBESEG="3,7,1,2,4,5,6"
41 F I=1:1:$L(LRBESEG,",") S LRBEA=+$P(LRBESEG,",",I) D Q:LRBEQT
42 .I $D(LRBECLY(LRBEA)) D Q:LRBEQT
43 ..S DIR("A")=" "_$$GETI(LRBEA)
44 ..S DIR(0)="YO" D ^DIR
45 ..I $D(DTOUT)!($D(DUOUT)) S (LRBEST,LRBEQT)=1 K DIC,LRBEAR Q:LRBEQT
46 ..I +Y=-1 S LRBEQT=1 Q:LRBEQT
47 ..S $P(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,TST,LRBEDGX),U,LRBEA+3)=Y
48 ..S $P(LRBEDP(LRBEDGX),U,LRBEA+3)=Y
49 Q
50 ;
51GETI(LRBEA) ; Get type of Indicator
52 N LRBEX,LRBEQUES,LRBEQUS1
53 S LRBEQUES="Was treatment related to ",LRBEQUS1="Was treatment for a "
54 S:LRBEA=1 LRBEX=LRBEQUES_"Agent Orange exposure"
55 S:LRBEA=2 LRBEX=LRBEQUES_"Ionizing Radiation exposure"
56 S:LRBEA=3 LRBEX=LRBEQUS1_"Service Connected condition"
57 S:LRBEA=4 LRBEX=LRBEQUES_"Environmental Contaminant exposure"
58 S:LRBEA=5 LRBEX=LRBEQUES_"Military Sexual Trauma"
59 S:LRBEA=6 LRBEX=LRBEQUES_"Head and Neck Cancer"
60 S:LRBEA=7 LRBEX=LRBEQUES_"Combat Vet"
61 Q LRBEX
62 ;
63ERRMSG(MT) ; Display Error Message
64 N LRBEAST,LRBEFMT,LRBELIN,LRBEMS
65 S:MT=-1 LRBEMS="An error occurred. Data may or may not have been processed."
66 S:MT<-1 LRBEMS="No data was processed."
67 S LRBEMS="* "_LRBEMS_" *",LRBEAST="",$P(LRBEAST,"*",80)="",LRBEFMT="!?"_((80-$L(LRBEMS))/2)
68 S LRBELIN=$E(LRBEAST,1,$L(LRBEMS)+1)
69 D EN^DDIOL(LRBELIN,"",LRBEFMT),EN^DDIOL(LRBEMS,"",LRBEFMT),EN^DDIOL(LRBELIN,"",LRBEFMT)
70 Q
71 ;
72SDG1(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,LRBEAR) ; Set the diagnois
73 ; and indicators file #69
74 N LRBEFIL,LRBEIEN,LRBEDFN,LRFDA,LRFDAIEN,LRERR,LRBEPDGX,LRBETNUM
75 N LRDA,LRBEP,DIK,DA
76 S DIK="^LRO(69,"_LRODT_",1,"_LRSN_",2,"_LRTN_",2,"
77 S LRDA=0 F S LRDA=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,2,LRDA)) Q:LRDA<1 D
78 . S DA=LRDA D ^DIK
79 K DA,DIK
80 S LRBEP=0
81 I '$D(DFN) S LRBEDFN=$$GET1^DIQ(63,LRDFN,.03,"I")
82 S:$D(DFN) LRBEDFN=DFN
83 S LRBEFIL=69.05,LRBETNUM=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,2,""),-1)+1,LRBEPDGX=""
84 F S LRBEPDGX=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRSAMP,LRSPEC,LRTSTS,LRBEPDGX)) Q:LRBEPDGX="" D
85 .S LRBEPTDT=$G(LRBEAR(LRBEDFN,"LRBEDGX",LRSAMP,LRSPEC,LRTSTS,LRBEPDGX))
86 .I 'LRBEP,'$P(LRBEPTDT,U,11) Q
87 .S LRBEP=1
88 .S LRBEIEN="+"_LRBETNUM_","_LRTN_","_LRSN_","_LRODT_","
89 .S LRFDAIEN(LRBETNUM)=LRBETNUM
90 .S LRFDA(99,LRBEFIL,LRBEIEN,.01)=LRBEPDGX
91 .S:$P(LRBEPTDT,U,6)'="" LRFDA(99,LRBEFIL,LRBEIEN,1)=$P(LRBEPTDT,U,6)
92 .S:$P(LRBEPTDT,U,10)'="" LRFDA(99,LRBEFIL,LRBEIEN,2)=$P(LRBEPTDT,U,10)
93 .S:$P(LRBEPTDT,U,4)'="" LRFDA(99,LRBEFIL,LRBEIEN,3)=$P(LRBEPTDT,U,4)
94 .S:$P(LRBEPTDT,U,5)'="" LRFDA(99,LRBEFIL,LRBEIEN,4)=$P(LRBEPTDT,U,5)
95 .S:$P(LRBEPTDT,U,7)'="" LRFDA(99,LRBEFIL,LRBEIEN,5)=$P(LRBEPTDT,U,7)
96 .S:$P(LRBEPTDT,U,8)'="" LRFDA(99,LRBEFIL,LRBEIEN,6)=$P(LRBEPTDT,U,8)
97 .S:$P(LRBEPTDT,U,9)'="" LRFDA(99,LRBEFIL,LRBEIEN,7)=$P(LRBEPTDT,U,9)
98 .S:$P(LRBEPTDT,U,11)=1 LRFDA(99,LRBEFIL,LRBEIEN,8)=1 ;Is Primary?
99 .S LRBETNUM=LRBETNUM+1
100 .I $P(LRBEPTDT,U,11) K LRBEAR(LRBEDFN,"LRBEDGX",LRSAMP,LRSPEC,LRTSTS,LRBEPDGX) S LRBEPDGX=""
101 D UPDATE^DIE("","LRFDA(99)","LRFDAIEN","LRERR")
102 Q
103 ;
104SDOS(LRODT,LRSN,LRTN,LRBECDT) ; Set DOS for CIDC
105 N LRBEIEN,LRFDA,LRERR
106 S LRBEIEN=LRTN_","_LRSN_","_LRODT_",",LRFDA(99,69.03,LRBEIEN,22)=LRBECDT
107 D UPDATE^DIE("","LRFDA(99)","","LRERR")
108 Q
109 ;
110CCPT(LRBECPT,LRBECDT,LRBEAR) ; Check the status of the CPT (CSV)
111 ;
112 ; Input:
113 ; LRBECPT - CPT
114 ; LRBECDT - Date To Be Checked ; Collection date/time
115 ; LRBEAR - An array passed by reference to hold IEN and Status
116 ;
117 ; Output:
118 ; ST - Status of CPT (Active (1),Inactive (0), or Invalid (-1))
119 ; LRBEAR - An array passed by reference to hold IEN and Status
120 ; LRBEAR(CPT)=IEN^NAME^EFFECTIVE DAT^STATUS
121 ;
122 N LRBEST,LRBEPTDT
123 S LRBEST=""
124 S LRBEPTDT=$$CPT^ICPTCOD(LRBECPT,LRBECDT)
125 S LRBEST=$P(LRBEPTDT,U,7) I 'LRBEST S LRBEST=-1 Q LRBEST
126 S LRBEAR(LRBECPT)=$P(LRBEPTDT,U,1)_U_$P(LRBEPTDT,U,3)_U_$P(LRBEPTDT,U,6)_U_LRBEST
127 Q LRBEST
128 ;
129EMSGCPT(LRBEAR) ; Print out Inactive CPTs
130 N CNAM,LRBEASK,LRBEFMT,LRBELIN,LRBECPT,LRBEMS,LRBEMS2,LRBEMS3,LRBEMSG,LRBESP
131 S LRBEMSG="Please contact HISYS to correct the Inactive CPTs: "
132 S LRBEMS="* "_LRBEMSG_" *",LRBEAST="",$P(LRBEAST,"*",80)="",LRBEFMT="!?"_((80-$L(LRBEMS))/2)
133 S LRBESP="",$P(LRBESP," ",80)="",LRBELIN=$E(LRBEAST,1,$L(LRBEMS))
134 S LRBEMS2="* "_$E(LRBESP,1,$L(LRBEMSG))_" *"
135 D EN^DDIOL(LRBELIN,"","!"_LRBEFMT),EN^DDIOL(LRBEMS,"",LRBEFMT),EN^DDIOL(LRBEMS2,"",LRBEFMT)
136 S LRBECPT="" F S LRBECPT=$O(LRBEAR(LRBECPT)) Q:LRBECPT="" D
137 .Q:$P(LRBEAR(LRBECPT),U,4)'=0
138 .S CNAM=$P(LRBEAR(LRBECPT),U,2)
139 .S LRBEMS3="* "_LRBECPT_$E(LRBESP,1,15-$L(LRBECPT))_$E(CNAM,1,30)
140 .S LRBEMS3=LRBEMS3_$E(LRBESP,1,($L(LRBEMS)-$L(LRBEMS3))-1)_"*"
141 .D EN^DDIOL(LRBEMS3,"",LRBEFMT)
142 D EN^DDIOL(LRBEMS2,"",LRBEFMT),EN^DDIOL(LRBELIN,"",LRBEFMT)
143 Q
144 ;
145BAWRK(LRODT,LRSN,LRI,LRBEY,LRTEST,LRBEDEL,LRBEVST,LRBEROLL,ORIEN) ; Send the Billing Information to PCE
146 ;input LRBEROLL = 1, if processing from routine LRBEBA5 for roll-up to PCE
147 ;input ORIEN = OERR Order #; only passed from WORK^LRBEBA4
148 Q:$G(LRCHG)=1
149 K ^TMP("LRPXAPI",$J),LRBEAR,LRBEAR1,LRBECPT
150 N D0,DA,DIC,DIE,DIR,I,T,X1,X2,X3,X9,Z,Z1,Z2,CNT,VADM,VAIN
151 N LRBETEST,LRTN,LRBESB,LRBETST,LRBEPAN,LRBEMSG,LRDBEDGX,LRBESEQ,LRNOP,LRX
152 N PXBREQ,LRVN,PXKDONE
153 I '$G(LRPKG) D
154 . S LRPKG=$$FIND1^DIC(9.4,,"B","LAB SERVICE","B","","ERR")
155 I LRPKG<1 D Q
156 . D EN^DDIOL("PCE Error Condition - Lab Service package not installed","","!")
157 N LRBEAR,LRBEDFN,LRBECDT,LRBEU,LRBEX,LRBEZ,LRBETYP,LRBECDT
158 N LRBENO,LRBEMOD,LROOS,LRPCECNT,LRI,X,Y,USR
159 M LRBETEST=LRTEST
160 M LRBESB=LRSB
161 S LROOS=$$GET1^DIQ(68,LRAA,.8,"I") I 'LROOS S LROOS=$$GET1^DIQ(69.9,1,.8,"I")
162 S LRBEMOD=$$GMOD^LRBEBA2(LRAA)
163 S LRBEDEL=$G(LRBEDEL)
164 I $G(LRDFN) S:'$G(DFN) DFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
165 S LRBEDFN=DFN
166 S:'$G(LRBEVST) LRBEVST=$P($G(^LRO(69,LRODT,1,LRSN,"PCE")),";")
167 S (LRBECDT,LRBEDT)=$J($$GET1^DIQ(69.01,LRSN_","_LRODT_",",10,"I"),7,4)
168 S I=0 F S I=$O(LRBETEST(I)) Q:I<1 D
169 . S LRBETST=$P(LRBETEST(I),U,1)
170 . S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
171 . I LRTN D SDOS(LRODT,LRSN,LRTN,LRBECDT)
172 G:$G(LRBENO) KILL
173 D BLDAR^LRBEBA3(LRBEDFN,LRODT,LRSN,.LRBEAR,.LRBEY,.LRBETEST,.LRBEPAN,LRBEDEL) G:$G(LRBENO) KILL
174 D STDN^LRBEBA2(LRODT,LRSN,.LRBETEST,.LRBEY) G:$G(LRBENO) KILL
175 D SOP^LRBEBA2(LRBEDFN,.LRBESB,.LRBEY,.LRBEPAN,$G(LRBEROLL)) G:$G(LRBENO) KILL
176 I $D(LRBECPT)>1 D
177 .D OPORD^LRBEBAO Q:$G(LRBENO)
178 .D OPRES^LRBEBAO(.LRBEAR,.LRBEAR1,LRODT,LRSN,LRBEVST)
179KILL ;
180 K ^TMP("LRPXAPI",$J)
181 K LRPKG,LRBEDIA,LRBEVSIT,LRBEAR,LRBEAR1,LRBEDEL,LRBEDT,LRBEPOS
182 K LRBEIEN,LRBEMOD,LRBEPTDT,LRBETM,LRBEDN,LRBESMP,LRBESPC,LRBEDGX,LRBEVST,LROOS,LRBERES
183 K ERRDIS,INROOT,SRC,SUB1,SUB2,SUB3,USR
184 I '$G(LRBEROLL) K LRBECPT,LRBEY
185 Q
186 ;
187GEDT(LRODT,LRSN,LRBETST) ; Get the Date of Service
188 N X,Y,LRBEIEN,DIC,LRBEEDT
189 S LRBEEDT=""
190 S X=$$GET1^DIQ(60,LRBETST_",",.01)
191 S DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,"
192 S DIC(0)="Z" D ^DIC I +Y<0 K DIC Q 0
193 S LRBEIEN=+Y_","_LRSN_","_LRODT_","
194 S LRBEEDT=$$GET1^DIQ(69.03,LRBEIEN,22,"I")
195 Q LRBEEDT
196 ;
197GCDT(LRODT,LRSN) ; Get the collection date/time
198 N LRBECDT,LRBEIEN
199 S LRBECDT=""
200 S LRBEIEN=LRSN_","_LRODT_","
201 S LRBECDT=$$GET1^DIQ(69.01,LRBEIEN,10,"I")
202 Q LRBECDT
Note: See TracBrowser for help on using the repository browser.