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