source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL1.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 7.9 KB
Line 
1ORQQPL1 ; ALB/PDR/REV - PROBLEM LIST FOR CPRS GUI ;03/12/02
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,148,173,203,206,249**;Dec 17, 1997
3 ;
4 ;------------------------- GET PROBLEM FROM LEXICON -------------------
5 ;
6LEXSRCH(LIST,FROM,N,VIEW,ORDATE) ; Get candidate Problems from LEX file
7 N LEX,VAL,VAL1,COD,CIEN,SYS,MAX,NAME
8 S:'+$G(ORDATE) ORDATE=DT
9 S:'$G(N) N=100
10 S:'$L($G(VIEW)) VIEW="PL1"
11 D CONFIG^LEXSET("GMPL",VIEW,ORDATE)
12 D LOOK^LEXA(FROM,"GMPL",N,"",ORDATE)
13 S S=0
14 F S S=$O(LEX("LIST",S)) Q:S<1 D
15 . S VAL1=LEX("LIST",S)
16 . S COD="",CIEN="",SYS="",NAME=""
17 . I $L(VAL1,"CPT-4 ")>1 D
18 .. ;S SYS="CPT-4 "
19 .. ;S COD=$P($P(VAL1,SYS,2),")")
20 .. ;S:COD["/" COD=$P(COD,"/",1)
21 .. ;. S CIEN=$$CODEN^ICPTCOD(COD)
22 .. S SYS="ICD-9-CM "
23 .. S COD="799.9"
24 .. S CIEN=""
25 .. S NAME=$P(VAL1," (CPT-4")
26 . I $L(VAL1,"DSM-IV ")>1 D
27 .. S SYS="DSM-IV "
28 .. S COD=$P($P(VAL1,SYS,2),")")
29 .. S:COD["/" COD=$P(COD,"/",1)
30 .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80)
31 .. S NAME=$P(VAL1," (DSM-IV")
32 .. ;
33 . I $L(VAL1,"(TITLE 38 ")>1 D
34 .. S SYS="TITLE 38 "
35 .. S COD=$P($P(VAL1,SYS,2),")")
36 .. S:COD["/" COD=$P(COD,"/",1)
37 .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80)
38 .. S NAME=$P(VAL1,"(TITLE 38 ")
39 .. ;
40 . I $L(VAL1,"ICD-9-CM ")>1 D
41 .. S SYS="ICD-9-CM "
42 .. S COD=$P($P(VAL1,SYS,2),")")
43 .. S:COD["/" COD=$P(COD,"/",1)
44 .. S CIEN=+$$CODEN^ICDCODE(COD,80)
45 .. S NAME=$P(VAL1," (ICD-9-CM")
46 . I $L(NAME)=0 S NAME=$P($P(VAL1," (")," *")
47 . ;
48 . ; jeh Clean left over codes
49 . S NAME=$P(NAME," (CPT-4")
50 . S NAME=$P(NAME," (DSM-IV")
51 . S NAME=$P(NAME,"(TITLE 38 ")
52 . S NAME=$P(NAME," (ICD-9-CM")
53 . ;
54 . S VAL=NAME_U_COD_U_CIEN_U_SYS ; ien^.01^icd^icdifn^system
55 . S LIST(S)=VAL
56 . S MAX=S
57 I $G(MAX)'="" S LIST(MAX+1)=$G(LEX("MAT"))
58 Q
59 ;
60ICDREC(COD) ;
61 N CODIEN
62 I COD="" Q ""
63 S COD=$P($P(COD,U),"/")
64 S CODIEN=+$O(^ICD9("AB",COD_" ",0))
65 S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",COD_"0 ",0))
66 Q CODIEN
67 ;Q $O(^ICD9("BA",COD,""))
68 ;
69CPTREC(COD) ;
70 I COD="" Q ""
71 Q $O(^ICPT("BA",COD,""))
72 ;
73EDLOAD(RETURN,DA,GMPROV,GMPVAMC) ; LOAD EDIT ARRAYS
74 ; DA=problem IFN
75 N I,GMPFLD,GMPORIG,GMPL
76 D GETFLDS^GMPLEDT3(DA)
77 S I=0
78 D LOADFLDS(.RETURN,"GMPFLD","NEW",.I)
79 D LOADFLDS(.RETURN,"GMPORIG","ORG",.I)
80 K GMPFLD,GMPORIG,GMPL ; should not have to do this
81 Q
82 ;
83LOADFLDS(RETURN,NAM,TYP,I) ; LOAD FIELDS FOR TYPE OF ARRAY
84 N S,V,CVP,PN,PID
85 S S="",V=$C(254)
86 F S S=$O(@NAM@(S)) Q:S=10 D
87 . S RETURN(I)=TYP_V_S_V_@NAM@(S)
88 . S I=I+1
89 S S=""
90 F S S=$O(@NAM@(10,S)) Q:S="" D
91 . S CVP=@NAM@(10,S)
92 . S PN="" ; provider name
93 . S PID=$P(CVP,U,6) ; provider id
94 . I PID'="" S PN=$$GET1^DIQ(200,PID,.01) ; get provider name
95 . S RETURN(I)=TYP_V_"10,"_S_V_CVP_U_PN
96 . S I=I+1
97 Q
98 ;
99EDSAVE(RETURN,GMPIFN,GMPROV,GMPVAMC,UT,EDARRAY) ; SAVE EDITED RES
100 ; RETURN - boolean, 1 success, 0 failure
101 ; EDARRAY - array used for indirect sets of GMPORIG() and GMPFLDS()
102 ;
103 N GMPFLD,GMPORIG,S,GMPLUSER
104 S RETURN=1 ; initialize for success
105 I UT S GMPLUSER=1
106 ;
107 ;S GMPLUSER=1
108 S S=""
109 F S S=$O(EDARRAY(S)) Q:S="" D
110 . S @EDARRAY(S)
111 I $D(GMPFLD(10,"NEW"))>9 D I 'RETURN Q ; Bail Out if no lock
112 . L +^AUPNPROB(GMPIFN,11):10 ; given bogus nature of this lock, should be able to get
113 . I '$T S RETURN=0
114 ;
115 D EN^GMPLSAVE ; save the data
116 K GMPFLD,GMPORIG
117 ;
118 L -^AUPNPROB(GMPIFN,11) ; free this instance of lock (in case it was set)
119 S RETURN=1
120 Q
121 ;
122UPDATE(ORRETURN,UPDARRAY) ; UPDATE A PROBLEM RECORD
123 ; Does essentially same job as EDSAVE above, however does not handle edits to comments
124 ; or addition of multiple comments.
125 ; Use initially just for status updates.
126 ;
127 N S,GMPL,GMPORIG ; last 2 vars created in nested call
128 S S=""
129 F S S=$O(UPDARRAY(S)) Q:S="" D
130 . S @UPDARRAY(S)
131 D UPDATE^GMPLUTL(.ORARRAY,.ORRETURN)
132 K ORARRAY
133 ; broker wont pick up root node RETURN
134 S ORRETURN(1)=ORRETURN(0) ; error text
135 S ORRETURN(0)=ORRETURN ; gmpdfn
136 I ORRETURN(0)="" S ORRETURN=1 ; insurance ? need
137 Q
138 ;
139ADDSAVE(RETURN,GMPDFN,GMPROV,GMPVAMC,ADDARRAY) ; SAVE NEW RECORD
140 ; RETURN - Problem IFN if success, 0 otherwise
141 ; ADDARRAY - array used for indirect sets of GMPFLDS()
142 ;
143 N DA,GMPFLD,GMPORIG,S
144 S RETURN=0 ;
145 L +^AUPNPROB(0):10
146 Q:'$T ; bail out if no lock
147 ;
148 S S=""
149 F S S=$O(ADDARRAY(S)) Q:S="" D
150 . S @ADDARRAY(S)
151 ;
152 D NEW^GMPLSAVE
153 ;
154 S RETURN=DA
155 ;
156 L -^AUPNPROB(0)
157 S RETURN=1
158 Q
159 ;
160INITUSER(RETURN,ORDUZ) ; INITIALIZE FOR NEW USER
161 ; taken from INIT^GMPLMGR
162 ; leave GMPLUSER on symbol table - is evaluated in EDITSAVE
163 ;
164 N X,PV,CTXT,GMPLPROV
165 S GMPLUSER=$$CLINUSER(DUZ)
166 S CTXT=$$GET^XPAR("ALL","ORCH CONTEXT PROBLEMS",1)
167 S X=$G(^GMPL(125.99,1,0)) ; IN1+6^GMPLMGR
168 S RETURN(0)=GMPLUSER ; problem list user, or other user
169 S RETURN(1)=$$VIEW^GMPLX1(DUZ) ; GMPLVIEW("VIEW") - users default view
170 S RETURN(2)=+$P(X,U,2) ; verify transcribed problems
171 S RETURN(3)=+$P(X,U,3) ; prompt for chart copy
172 S RETURN(4)=+$P(X,U,4) ; use lexicon
173 S RETURN(5)=$S($P(X,U,5)="R":1,1:0) ; chron or reverse chron listing
174 S RETURN(6)=$S($P($G(CTXT),";",3)'="":$P($G(CTXT),";",3),1:"A")
175 S GMPLPROV=$P($G(CTXT),";",5)
176 I +GMPLPROV>0,$D(^VA(200,GMPLPROV)) D
177 . S RETURN(7)=GMPLPROV_U_$P(^VA(200,GMPLPROV,0),U)
178 E S RETURN(7)="0^All"
179 S RETURN(8)=$$SERVICE^GMPLX1(DUZ) ; user's service/section
180 ; Guessing from what I see in the data that $$VIEW^GMPLX1 actually returns a composite
181 ; of default view (in/out patient)/(c1/c2... if out patient i.e. GMPLVIEW("CLIN")) or
182 ; /(s1/s2... if in patient i.e. GMPLVIEW("SERV"))
183 ; Going with this assumption for now:
184 I $L(RETURN(1),"/")>1 D
185 . S PV=RETURN(1)
186 . S RETURN(1)=$P(PV,"/")
187 . I RETURN(1)="C" S GMPLVIEW("CLIN")=$P(PV,"/",2,99)
188 . I RETURN(1)="S" S GMPLVIEW("SERV")=$P(PV,"/",2,99)
189 S RETURN(9)=$G(GMPLVIEW("SERV")) ; ??? Where from - see tech doc
190 S RETURN(10)=$G(GMPLVIEW("CLIN")) ; ??? Where from - see tech doc
191 S RETURN(11)=""
192 S RETURN(12)=+$P($G(CTXT),";",4) ; should comments display?
193 K GMPLVIEW
194 Q
195 ;
196CLINUSER(ORDUZ) ;is this a clinical user?
197 N ORUSER
198 S ORUSER=0
199 I $D(^XUSEC("ORES",ORDUZ)) S ORUSER=1
200 I $D(^XUSEC("ORELSE",ORDUZ)) S ORUSER=1
201 I $D(^XUSEC("PROVIDER",ORDUZ)) S ORUSER=1
202 Q ORUSER
203 ;
204INITPT(RETURN,DFN) ; GET PATIENT PARAMETERS
205 Q:+$G(DFN)=0
206 N GMPSC,GMPAGTOR,GMPION,GMPGULF,GMPHNC,GMPMST
207 ;
208 S RETURN(0)=DUZ(2) ; facility #
209 D DEM^VADPT ; get death indicator
210 S RETURN(1)=$G(VADM(6)) ; death indicator
211 D VADPT^GMPLX1(DFN) ; get eligibilities
212 S RETURN(2)=$P(GMPSC,U) ; service connected
213 S RETURN(3)=$G(GMPAGTOR) ; agent orange exposure
214 S RETURN(4)=$G(GMPION) ; ionizing radiation exposure
215 S RETURN(5)=$G(GMPGULF) ; gulf war exposure
216 S RETURN(6)=VA("BID") ; need this to reconstitute GMPDFN on return
217 S RETURN(7)=$G(GMPHNC) ; head/neck cancer
218 S RETURN(8)=$G(GMPMST) ; MST
219 Q
220 ;
221PROVSRCH(LST,FLAG,N,FROM,PART) ; Get candidate Rroviders from person file
222 N LV,NS,RV,IEN
223 S RV=$NAME(LV("DILIST","ID"))
224 IF +$G(N)=0 S N=50
225 S FLAG=$G(FLAG),N=$G(N),FROM=$G(FROM),PART=$G(PART)
226 D LIST^DIC(200,"",".01;1",FLAG,N,FROM,PART,"","","","LV")
227 S NS=""
228 F S NS=$O(LV("DILIST",1,NS)) Q:NS="" D
229 . S IEN=""
230 . S IEN=$O(^VA(200,"B",@RV@(NS,.01),IEN)) ; compliments of PROV^ORQPTQ
231 . S LST(NS)=IEN_U_@RV@(NS,.01) ; initials_U_@RV@(NS,1)
232 Q
233 ;
234CLINSRCH(Y,X) ; Get LIST OF CLINICS
235 ; Note: This comes from CLIN^ORQPTQ2, where it was commented out in place of
236 ; a call to ^XPAR. I would have just used CLIN^ORQPTQ2, but it didn't work - at
237 ; least on SLC OEX directory.
238 ; X has no purpose other than to satisfy apparent rpc and tcallv requirement for args
239 N I,NAME,IEN
240 S I=1,IEN=0,NAME=""
241 ;access to SC global granted under DBIA #518:
242 F S NAME=$O(^SC("B",NAME)) Q:NAME="" S IEN=$O(^(NAME,0)) D
243 . I $P(^SC(IEN,0),"^",3)="C" S Y(I)=IEN_"^"_NAME,I=I+1
244 Q
245 ;
246SRVCSRCH(Y,FROM,DIR,ALL) ; GET LIST OF SERVICES
247 N I,IEN,CNT S I=0,CNT=44
248 F Q:I=CNT S FROM=$O(^DIC(49,"B",FROM),DIR) Q:FROM="" D
249 . S IEN=$O(^DIC(49,"B",FROM,0)) I '$G(ALL),$P(^DIC(49,IEN,0),U,9)'="C" Q
250 . S I=I+1,Y(I)=IEN_"^"_FROM
251 Q
252 ;
253DUP(Y,DFN,TERM,TEXT) ;Check for duplicate problem
254 S Y=$$DUPL^GMPLX(DFN,TERM,TEXT) Q:+Y=0
255 I $P(^AUPNPROB(Y,1),U,2)="H" S Y=0 Q
256 S Y=Y_U_$P(^AUPNPROB(Y,0),U,12)
257 Q
Note: See TracBrowser for help on using the repository browser.