| 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
|
|---|
