- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL3.m
r613 r623 1 ORQQPL3 ; 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 ; 6 PROBL(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 ; 24 LIST(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 ; 91 DELLIST(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 ; 140 GETSP() ; 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 ; 150 CAT(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 ; 169 GETUSLST(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 ; 179 PROB(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 ; 206 ICDCODE(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 ; 215 GETRPRV(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 ; 229 GETCLIN(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 ; 239 GETSRVC(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 1 ORQQPL3 ; ALB/PDR/REV ; Problem List RPC's ; 8-OCT-1998 09:08:49.29 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,148,173**;Dec 17, 1997 3 ; 4 ;---------------- LIST PATIENT PROBLEMS ------------------------ 5 ; 6 PROBL(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 ; 24 LIST(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,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 SCCOND=SC_AO_IR_ENV_HNC_MST 67 . S LOC=$P(GMPL1,U,8) 68 . S DTREC=$P(GMPL1,U,9) 69 . S LT="" 70 . I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3),LOC=LOC_";"_$P($G(^SC(LOC,0)),U,1) 71 . S PROV=$P(GMPL1,U,5) ; responsible provider 72 . I PROV'="" S PROV=PROV_";"_$P($G(^VA(200,PROV,0)),U,1) 73 . S SERV=$P(GMPL1,U,6) 74 . I SERV=0 S SERV="" ; not sure how it gets set to 0, but need consistency in GUI 75 . I SERV'="" S SERV=SERV_";"_$P($G(^DIC(49,SERV,0)),U,1) 76 . S SP="" 77 . F I=11,12,13 S:$P(GMPL1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P") 78 . S PRIO=$P(GMPL1,U,14) 79 . S LIN=IFN_U_ST_U_$$PROBTEXT^GMPLX(IFN)_U_ICD_U_ONSET 80 . S LIN=LIN_U_LASTMOD_U_SC_U_SP_U_$P(GMPL1,U,2) 81 . S LIN=LIN_U_LOC_U_LT_U_PROV_U_SERV_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT 82 . S GMPL(CNT)=LIN 83 S GMPL(0)=CNT 84 Q 85 ; 86 ; 87 ;------------------------------------- GET LIST OF DELETED PROBLEMS ----------------------------- 88 ; 89 DELLIST(RETURN,GMPDFN) ; GET LIST OF DELETED PROBLEMS 90 ; see GETPLIST^GMPLMGR1 and LIST^GMPUTL2 91 N S,IFN,I,L0,L1,ST,TXT,ICD,ONSET,MOD,SC,SP,LOC,LT,PROV,SERV,PRIO,HASCMT,DTREC 92 N SCCOND,AO,IR,ENV,HNC,MST,ORICD186,INACT 93 S I=0,S="" 94 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6") 95 F S S=$O(^AUPNPROB("ACTIVE",GMPDFN,S)) Q:S="" D 96 . S IFN="" 97 . F S IFN=$O(^AUPNPROB("ACTIVE",+GMPDFN,S,IFN)) Q:IFN="" D 98 .. I $P($G(^AUPNPROB(IFN,1)),U,2)="H" D 99 ... S L0=$G(^AUPNPROB(IFN,0)) 100 ... Q:L0="" 101 ... S INACT="" 102 ... S L1=$G(^AUPNPROB(IFN,1)) 103 ... S ST=$P(L0,U,12) 104 ... S TXT=$$PROBTEXT^GMPLX(IFN) 105 ... I +ORICD186 D 106 ... . S ICD=$$CODEC^ICDCODE(+L0) 107 ... . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#" 108 ... E D 109 ... . S ICD=$P($G(^ICD9(+L0,0)),U) 110 ... S ONSET=$P(L0,U,13) 111 ... S MOD=$P(L0,U,3) 112 ... S SC=$S(+$P(L1,U,10):"SC",$P(L1,U,10)=0:"NSC",1:"") 113 ... S AO=$S(+$P(L1,U,11):"/AO",1:"") 114 ... S IR=$S(+$P(L1,U,12):"/IR",1:"") 115 ... S ENV=$S(+$P(L1,U,13):"/EC",1:"") 116 ... S HNC=$S(+$P(L1,U,15):"/HNC",1:"") 117 ... S MST=$S(+$P(L1,U,16):"/MST",1:"") 118 ... S SCCOND=SC_AO_IR_ENV_HNC_MST 119 ... S SP=$$GETSP 120 ... S LOC=$P(L1,U,8) 121 ... S LT="" 122 ... I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3) 123 ... S PROV=$P(L1,U,5) ; responsible provider 124 ... S SERV=$P(L1,U,6) 125 ... S PRIO=$P(L1,U,14) 126 ... S HASCMT=($D(^AUPNPROB(IFN,11,0))>0) 127 ... S DTREC=$P(L1,U,9) 128 ... S I=I+1 129 ... S RETURN(I)=IFN_U_ST_U_TXT_U_ICD_U_ONSET 130 ... S RETURN(I)=RETURN(I)_U_MOD_U_SC_U_SP_U_$P(L1,U,2) 131 ... S RETURN(I)=RETURN(I)_U_LOC_U_LT_U_PROV_U_SERV 132 ... S RETURN(I)=RETURN(I)_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT 133 S RETURN(0)=I 134 Q 135 ; 136 GETSP() ; GET EXPOSURES 137 N I 138 S SP="" 139 F I=11,12,13 S:$P(L1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P") 140 Q SP 141 ; 142 ; adapted from ^GMPLBLD3 ;9/96 143 ; 144 ; ----------------------- GET USER PROBLEM CATEGORIES -------------- 145 ; 146 CAT(TMP,ORDUZ,CLIN) ; Get user category list 147 N GSEQ,GCNT,GROUP,HDR,IFN,LCNT,ITEM,TG,GMPLSLST 148 ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing 149 S TG=$NAME(TMP) ; put list in local 150 K @TG 151 S (GSEQ,GCNT,LCNT)=0 152 ; 153 S GMPLSLST=$$GETUSLST(DUZ,CLIN) ; get approp list for user 154 ; Build multiple of category\problems 155 ; Iterate categories 156 F S GSEQ=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ)) Q:GSEQ'>0 D 157 . S IFN=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ,0)) Q:IFN'>0 158 . S ITEM=$G(^GMPL(125.1,IFN,0)) 159 . S GROUP=+$P(ITEM,U,3) 160 . S HDR=GROUP_U_$P(ITEM,U,4,5) 161 . S GCNT=GCNT+1 162 . S @TG@(GCNT)=HDR ; put category into temp global 163 Q 164 ; 165 GETUSLST(ORDUZ,CLIN) ; GET AN APPROPRIATE CATEGORY LIST FOR THE USER 166 N GMPLSLST 167 S GMPLSLST=$P($G(^VA(200,DUZ,125)),U,2) 168 ;I 'GMPLSLST D 169 I 'GMPLSLST,CLIN,$D(^GMPL(125,"C",+CLIN)) S GMPLSLST=$O(^(+CLIN,0)) 170 ;. S GMPLSLST=$O(^VA(200,DUZ,+CLIN,0)) ;$O(^(+CLIN,0)) 171 Q GMPLSLST 172 ; 173 ;----------------------- USER PROBLEM LIST -------------------------- 174 ; 175 PROB(TMP,GROUP) ; Get user problem list for given group 176 N PSEQ,PCNT,IFN,ITEM,TG,CODE,TEXT,ORICD186 177 ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing 178 S TG=$NAME(TMP) ; put list in local 179 K @TG 180 S LCNT=0 181 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6") 182 ; 183 ; iterate through problems in category 184 S (PSEQ,PCNT)=0 185 F S PSEQ=$O(^GMPL(125.12,"C",GROUP,PSEQ)) Q:PSEQ'>0 D 186 . S IFN=$O(^GMPL(125.12,"C",GROUP,PSEQ,0)) Q:IFN'>0 187 . S ITEM=$G(^GMPL(125.12,IFN,0)) 188 . S TEXT=$P(ITEM,U,4) 189 . ; SEE DD for GMPL(125.12,4 : 190 . ; "...code which is to be displayed... generally assumed to be ICD" 191 . S CODE=$P(ITEM,U,5) 192 . I +ORICD186,'+$$STATCHK^ICDAPIU(CODE,DT) Q 193 . S PCNT=PCNT+1 194 . ; RETURN: 195 . ; PROBLEM^DISPLAY TEXT^CODE^CODE IFN 196 . I +ORICD186 D 197 . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$CODEN^ICDCODE(CODE,80) 198 . E D 199 . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$ICDCODE(CODE) 200 Q 201 ; 202 ICDCODE(COD) ; RETURN INTERNAL ICD FOR EXTERNAL CODE (obsolete after CSV patches released - RV) 203 N CODIEN 204 I COD="" Q "" 205 S CODIEN=+$O(^ICD9("AB",$P(COD,U)_" ",0)) 206 S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",$P(COD,U)_"0 ",0)) 207 Q CODIEN 208 ; 209 ;------------------ Filter Providers --------------------- 210 ; 211 GETRPRV(RETURN,INP) ; GET LIST OF RESPONSIBLE PROVIDERS FROM PRBLM LIST 212 ; RETURN - aa list of responsible providers from which to select for filtering 213 ; INP - array of problem list providers to select from 214 ; 215 N S 216 S S="" 217 F I=1:1 S S=$O(INP(S)) Q:S="" D 218 . I INP(S)'="",$G(^VA(200,INP(S),0))'="" D Q ; get next 219 .. S RETURN(I)=INP(S)_U_$P(^VA(200,INP(S),0),U) 220 S RETURN(0)="-1"_U_"<None recorded>" ; return empty provider 221 Q 222 ; 223 ;---------------------------------------------------- GET FILTERED CLINIC LIST ------------------------ 224 ; 225 GETCLIN(RETURN,INP) ; Get FILTERED LIST OF CLINICS 226 ; RETURN NAMES FOR LIST OF CLINICS PASSED IN 227 N I,S 228 S S="" 229 F I=1:1 S S=$O(INP(S)) Q:S="" D 230 . I INP(S)'="",$G(^SC(INP(S),0))'="" D Q ; get next 231 .. S RETURN(I)=INP(S)_U_$P(^SC(INP(S),0),U,1) 232 ;. S RETURN(I)="-1"_U_"None" ; return empty location 233 Q 234 ; 235 GETSRVC(RETURN,INP) ; GET FILTERED LIST OF INPATIENT SERVICES 236 ; RETURN NAMES FOR LIST OF IEN PASSED IN 237 N I,S 238 S S="" 239 F I=1:1 S S=$O(INP(S)) Q:S="" D 240 . I INP(S)'="",$G(^DIC(49,INP(S),0))'="" D Q ; get next 241 .. S RETURN(I)=INP(S)_U_$P(^DIC(49,INP(S),0),U,1) 242 ;. S RETURN(I)="-1"_U_"None" ; return empty service 243 Q
Note:
See TracChangeset
for help on using the changeset viewer.
