source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL3.m@ 613

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

initial load of WorldVistAEHR
File size: 8.2 KB
Line 
1ORQQPL3 ; ALB/PDR/REV ; Problem List RPC's ; 8-OCT-1998 09:08:49.29
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,148,173,243**;Dec 17, 1997;Build 242
3 ;
4 ;---------------- LIST PATIENT PROBLEMS ------------------------
5 ;
6PROBL(ROOT,DFN,CONTEXT) ; GET LIST OF PATIENT PROBLEMS
7 N DIWL,DIWR,DIWF
8 N ST,ORI,ORX
9 S (LCNT,NUM)=0
10 S DIWL=1,DIWR=48,DIWF="C48"
11 S CONTEXT=";;"_$G(CONTEXT)
12 I CONTEXT=";;" S CONTEXT=";;A"
13 S ST=$P(CONTEXT,";",3)
14 ;
15 I ST="R" D DELLIST(.ROOT,+DFN) ; show deleted only
16 I ST'="R" D LIST(.ROOT,+DFN,ST) ; show others - don't trust ELSE here
17 ;
18 I ROOT(0)<1 D
19 . S LCNT=1
20 . S ROOT(1)=" "_$$PAD^ORCHTAB("No data available.",49)_"|"
21 Q
22 ;
23 ;
24LIST(GMPL,GMPDFN,GMPSTAT) ; -- Returns list of problems for patient GMPDFN
25 ; in GMPL(#)=ifn^status^description^ICD^onset^last modified^SC^SpExp^Condition^Loc^
26 ; loc.type^prov^service
27 ; & GMPL(0)=number of problems returned
28 ; This is virtually same as LIST^GMPLUTL2 except that it appends the
29 ; condition - T)ranscribed or P)ermanent,location,loc type,provider, service.
30 ;
31 N I,IFN,CNT,GMPL0,GMPL1,SP,ST,NUM,ONSET,ICD,LASTMOD,PRIO,DTREC
32 N SC,ORLIST,ORVIEW,GMPARAM,ORTOTAL,LIN,LOC,LT,PROV,SERV,HASCMT
33 N SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,ORICD186,INACT
34 Q:$G(GMPDFN)'>0
35 S CNT=0,SP=""
36 S GMPARAM("QUIET")=1
37 S GMPARAM("REV")=$P($G(^GMPL(125.99,1,0)),U,5)="R"
38 S ORVIEW("ACT")=GMPSTAT
39 S ORVIEW("PROV")=0
40 S ORVIEW("VIEW")=""
41 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
42 ;
43 D GETPLIST^GMPLMGR1(.ORLIST,.ORTOTAL,.ORVIEW)
44 ;
45 F NUM=0:0 S NUM=$O(ORLIST(NUM)) Q:NUM'>0 D
46 . S IFN=+ORLIST(NUM) Q:IFN'>0
47 . S INACT=""
48 . S GMPL0=$G(^AUPNPROB(IFN,0))
49 . S GMPL1=$G(^AUPNPROB(IFN,1))
50 . S HASCMT=($D(^AUPNPROB(IFN,11,0))>0)
51 . S CNT=CNT+1
52 . I +ORICD186 D
53 . . S ICD=$$CODEC^ICDCODE(+GMPL0)
54 . . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#"
55 . E D
56 . . S ICD=$P($G(^ICD9(+GMPL0,0)),U)
57 . S LASTMOD=$P(GMPL0,U,3)
58 . S ST=$P(GMPL0,U,12)
59 . S ONSET=$P(GMPL0,U,13)
60 . S SC=$S(+$P(GMPL1,U,10):"SC",$P(GMPL1,U,10)=0:"NSC",1:"")
61 . S AO=$S(+$P(GMPL1,U,11):"/AO",1:"")
62 . S IR=$S(+$P(GMPL1,U,12):"/IR",1:"")
63 . S ENV=$S(+$P(GMPL1,U,13):"/EC",1:"")
64 . S HNC=$S(+$P(GMPL1,U,15):"/HNC",1:"")
65 . S MST=$S(+$P(GMPL1,U,16):"/MST",1:"")
66 . S CV=$S(+$P(GMPL1,U,17):"/CV",1:"")
67 . S SHD=$S(+$P(GMPL1,U,18):"/SHD",1:"")
68 . S SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD
69 . S LOC=$P(GMPL1,U,8)
70 . S DTREC=$P(GMPL1,U,9)
71 . S LT=""
72 . I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3),LOC=LOC_";"_$P($G(^SC(LOC,0)),U,1)
73 . S PROV=$P(GMPL1,U,5) ; responsible provider
74 . I PROV'="" S PROV=PROV_";"_$P($G(^VA(200,PROV,0)),U,1)
75 . S SERV=$P(GMPL1,U,6)
76 . I SERV=0 S SERV="" ; not sure how it gets set to 0, but need consistency in GUI
77 . I SERV'="" S SERV=SERV_";"_$P($G(^DIC(49,SERV,0)),U,1)
78 . S SP=""
79 . F I=11,12,13 S:$P(GMPL1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P")
80 . S PRIO=$P(GMPL1,U,14)
81 . S LIN=IFN_U_ST_U_$$PROBTEXT^GMPLX(IFN)_U_ICD_U_ONSET
82 . S LIN=LIN_U_LASTMOD_U_SC_U_SP_U_$P(GMPL1,U,2)
83 . S LIN=LIN_U_LOC_U_LT_U_PROV_U_SERV_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT
84 . S GMPL(CNT)=LIN
85 S GMPL(0)=CNT
86 Q
87 ;
88 ;
89 ;------------------------------------- GET LIST OF DELETED PROBLEMS -----------------------------
90 ;
91DELLIST(RETURN,GMPDFN) ; GET LIST OF DELETED PROBLEMS
92 ; see GETPLIST^GMPLMGR1 and LIST^GMPUTL2
93 N S,IFN,I,L0,L1,ST,TXT,ICD,ONSET,MOD,SC,SP,LOC,LT,PROV,SERV,PRIO,HASCMT,DTREC
94 N SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,ORICD186,INACT
95 S I=0,S=""
96 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
97 F S S=$O(^AUPNPROB("ACTIVE",GMPDFN,S)) Q:S="" D
98 . S IFN=""
99 . F S IFN=$O(^AUPNPROB("ACTIVE",+GMPDFN,S,IFN)) Q:IFN="" D
100 .. I $P($G(^AUPNPROB(IFN,1)),U,2)="H" D
101 ... S L0=$G(^AUPNPROB(IFN,0))
102 ... Q:L0=""
103 ... S INACT=""
104 ... S L1=$G(^AUPNPROB(IFN,1))
105 ... S ST=$P(L0,U,12)
106 ... S TXT=$$PROBTEXT^GMPLX(IFN)
107 ... I +ORICD186 D
108 ... . S ICD=$$CODEC^ICDCODE(+L0)
109 ... . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#"
110 ... E D
111 ... . S ICD=$P($G(^ICD9(+L0,0)),U)
112 ... S ONSET=$P(L0,U,13)
113 ... S MOD=$P(L0,U,3)
114 ... S SC=$S(+$P(L1,U,10):"SC",$P(L1,U,10)=0:"NSC",1:"")
115 ... S AO=$S(+$P(L1,U,11):"/AO",1:"")
116 ... S IR=$S(+$P(L1,U,12):"/IR",1:"")
117 ... S ENV=$S(+$P(L1,U,13):"/EC",1:"")
118 ... S HNC=$S(+$P(L1,U,15):"/HNC",1:"")
119 ... S MST=$S(+$P(L1,U,16):"/MST",1:"")
120 ... S CV=$S(+$P(L1,U,17):"/CV",1:"")
121 ... S SHD=$S(+$P(L1,U,18):"/SHD",1:"")
122 ... S SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD
123 ... S SP=$$GETSP
124 ... S LOC=$P(L1,U,8)
125 ... S LT=""
126 ... I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3)
127 ... S PROV=$P(L1,U,5) ; responsible provider
128 ... S SERV=$P(L1,U,6)
129 ... S PRIO=$P(L1,U,14)
130 ... S HASCMT=($D(^AUPNPROB(IFN,11,0))>0)
131 ... S DTREC=$P(L1,U,9)
132 ... S I=I+1
133 ... S RETURN(I)=IFN_U_ST_U_TXT_U_ICD_U_ONSET
134 ... S RETURN(I)=RETURN(I)_U_MOD_U_SC_U_SP_U_$P(L1,U,2)
135 ... S RETURN(I)=RETURN(I)_U_LOC_U_LT_U_PROV_U_SERV
136 ... S RETURN(I)=RETURN(I)_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT
137 S RETURN(0)=I
138 Q
139 ;
140GETSP() ; GET EXPOSURES
141 N I
142 S SP=""
143 F I=11,12,13 S:$P(L1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P")
144 Q SP
145 ;
146 ; adapted from ^GMPLBLD3 ;9/96
147 ;
148 ; ----------------------- GET USER PROBLEM CATEGORIES --------------
149 ;
150CAT(TMP,ORDUZ,CLIN) ; Get user category list
151 N GSEQ,GCNT,GROUP,HDR,IFN,LCNT,ITEM,TG,GMPLSLST
152 ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing
153 S TG=$NAME(TMP) ; put list in local
154 K @TG
155 S (GSEQ,GCNT,LCNT)=0
156 ;
157 S GMPLSLST=$$GETUSLST(DUZ,CLIN) ; get approp list for user
158 ; Build multiple of category\problems
159 ; Iterate categories
160 F S GSEQ=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ)) Q:GSEQ'>0 D
161 . S IFN=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ,0)) Q:IFN'>0
162 . S ITEM=$G(^GMPL(125.1,IFN,0))
163 . S GROUP=+$P(ITEM,U,3)
164 . S HDR=GROUP_U_$P(ITEM,U,4,5)
165 . S GCNT=GCNT+1
166 . S @TG@(GCNT)=HDR ; put category into temp global
167 Q
168 ;
169GETUSLST(ORDUZ,CLIN) ; GET AN APPROPRIATE CATEGORY LIST FOR THE USER
170 N GMPLSLST
171 S GMPLSLST=$P($G(^VA(200,DUZ,125)),U,2)
172 ;I 'GMPLSLST D
173 I 'GMPLSLST,CLIN,$D(^GMPL(125,"C",+CLIN)) S GMPLSLST=$O(^(+CLIN,0))
174 ;. S GMPLSLST=$O(^VA(200,DUZ,+CLIN,0)) ;$O(^(+CLIN,0))
175 Q GMPLSLST
176 ;
177 ;----------------------- USER PROBLEM LIST --------------------------
178 ;
179PROB(TMP,GROUP) ; Get user problem list for given group
180 N PSEQ,PCNT,IFN,ITEM,TG,CODE,TEXT,ORICD186
181 ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing
182 S TG=$NAME(TMP) ; put list in local
183 K @TG
184 S LCNT=0
185 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
186 ;
187 ; iterate through problems in category
188 S (PSEQ,PCNT)=0
189 F S PSEQ=$O(^GMPL(125.12,"C",GROUP,PSEQ)) Q:PSEQ'>0 D
190 . S IFN=$O(^GMPL(125.12,"C",GROUP,PSEQ,0)) Q:IFN'>0
191 . S ITEM=$G(^GMPL(125.12,IFN,0))
192 . S TEXT=$P(ITEM,U,4)
193 . ; SEE DD for GMPL(125.12,4 :
194 . ; "...code which is to be displayed... generally assumed to be ICD"
195 . S CODE=$P(ITEM,U,5)
196 . I +ORICD186,'+$$STATCHK^ICDAPIU(CODE,DT) Q
197 . S PCNT=PCNT+1
198 . ; RETURN:
199 . ; PROBLEM^DISPLAY TEXT^CODE^CODE IFN
200 . I +ORICD186 D
201 . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$CODEN^ICDCODE(CODE,80)
202 . E D
203 . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$ICDCODE(CODE)
204 Q
205 ;
206ICDCODE(COD) ; RETURN INTERNAL ICD FOR EXTERNAL CODE (obsolete after CSV patches released - RV)
207 N CODIEN
208 I COD="" Q ""
209 S CODIEN=+$O(^ICD9("AB",$P(COD,U)_" ",0))
210 S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",$P(COD,U)_"0 ",0))
211 Q CODIEN
212 ;
213 ;------------------ Filter Providers ---------------------
214 ;
215GETRPRV(RETURN,INP) ; GET LIST OF RESPONSIBLE PROVIDERS FROM PRBLM LIST
216 ; RETURN - aa list of responsible providers from which to select for filtering
217 ; INP - array of problem list providers to select from
218 ;
219 N S
220 S S=""
221 F I=1:1 S S=$O(INP(S)) Q:S="" D
222 . I INP(S)'="",$G(^VA(200,INP(S),0))'="" D Q ; get next
223 .. S RETURN(I)=INP(S)_U_$P(^VA(200,INP(S),0),U)
224 S RETURN(0)="-1"_U_"<None recorded>" ; return empty provider
225 Q
226 ;
227 ;---------------------------------------------------- GET FILTERED CLINIC LIST ------------------------
228 ;
229GETCLIN(RETURN,INP) ; Get FILTERED LIST OF CLINICS
230 ; RETURN NAMES FOR LIST OF CLINICS PASSED IN
231 N I,S
232 S S=""
233 F I=1:1 S S=$O(INP(S)) Q:S="" D
234 . I INP(S)'="",$G(^SC(INP(S),0))'="" D Q ; get next
235 .. S RETURN(I)=INP(S)_U_$P(^SC(INP(S),0),U,1)
236 ;. S RETURN(I)="-1"_U_"None" ; return empty location
237 Q
238 ;
239GETSRVC(RETURN,INP) ; GET FILTERED LIST OF INPATIENT SERVICES
240 ; RETURN NAMES FOR LIST OF IEN PASSED IN
241 N I,S
242 S S=""
243 F I=1:1 S S=$O(INP(S)) Q:S="" D
244 . I INP(S)'="",$G(^DIC(49,INP(S),0))'="" D Q ; get next
245 .. S RETURN(I)=INP(S)_U_$P(^DIC(49,INP(S),0),U,1)
246 ;. S RETURN(I)="-1"_U_"None" ; return empty service
247 Q
Note: See TracBrowser for help on using the repository browser.