- BQIPDSCF ;VNGT/HS/BEE-Panel Description Utility ; 7 Apr 2008 4:28 PM
- ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
- ;
- FILTER(OWNR,PLIEN,FPARMS) ;EP - Include filter description
- ;
- ; Retrieve all filters for this panel and return as a string in filter order
- ; as defined in the ICARE DEFINITIONS file (90506.03,.1)
- ;
- N DA,FIEN,FIENS,FSOURCE,FN,MN
- ;
- S DA(1)=OWNR,DA=PLIEN,FIENS=$$IENS^DILF(.DA)
- S FSOURCE=$$GET1^DIQ(90505.01,FIENS,.14,"E")
- ;
- ;Quit if filter turned off
- I FSOURCE="" Q ""
- ;
- S FIEN=$$PP^BQIDCDF(FSOURCE) ; Filter ien
- I FIEN=-1 S BMXSEC="Filter SOURCE was not found" Q ""
- ;
- ;Get each filter from panel definition
- S FN=0 F S FN=$O(^BQICARE(OWNR,1,PLIEN,15,FN)) Q:'FN D
- . NEW DA,IENS,FNAME,VALUE,PEXE,PTYP,PORD,VALUE,ASTR,PMAP,OFNAME
- . S DA(2)=OWNR,DA(1)=PLIEN,DA=FN,IENS=$$IENS^DILF(.DA)
- . S (OFNAME,FNAME)=$$GET1^DIQ(90505.115,IENS,.01,"E") Q:FNAME=""
- . S PTYP=$$PTYP^BQIDCDF(FSOURCE,FNAME) Q:PTYP=""
- . S PORD=$$PORD^BQIDCDF(FSOURCE,FNAME) Q:PORD=""
- . S VALUE=$$GVAL(PTYP,90505.115,IENS,FSOURCE,FNAME)
- . ;
- . ;Pull associate parameters
- . S ASTR=$$ASPARM^BQIPDSCL(FN)
- . ;
- . ;Call any defined executable
- . S PMAP=$$PMAP^BQIDCDF(FSOURCE,FNAME) I VALUE]"",PMAP]"" D MAP^BQIPDSCM(FSOURCE,PMAP,.VALUE,.FNAME)
- . S PEXE=$$PEXE^BQIDCDF(FSOURCE,FNAME) I VALUE]"",PEXE]"" X PEXE
- . ;
- . ;Save single value
- . I VALUE]"" D Q
- .. I $G(ASTR)="",FNAME="LAB",$G(VALUE)'="",VALUE["^" S VALUE=$P(VALUE,"^",1)
- .. I $G(ASTR)="",FNAME="MEAS",$G(VALUE)'="",VALUE["^" S VALUE=$P(VALUE,"^",1)
- .. I $G(ASTR)'="" D
- ... NEW RES
- ... I ASTR["NUMLAB" D
- .... S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1)
- .... S VALUE=VALUE_" is"_$$LBRS^BQIPDSC1(ASTR)
- ... NEW RES
- ... I ASTR["NUMMEAS" D
- .... S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1)
- .... S VALUE=VALUE_" is"_$$MSRS^BQIPDSC2(ASTR)
- ... I ASTR["SETLAB" D
- .... S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1),ASTR=$P(ASTR,"SETLAB",2)
- .... NEW LVAL,NVAL
- .... S VALUE=VALUE_" is "
- .... S ASTR=$TR(ASTR,$C(28),""),NVAL=$L(ASTR,$C(29))
- .... F I=1:1:NVAL S LVAL=$P(ASTR,$C(29),I) I LVAL'="" S VALUE=VALUE_$$SCD^BQIUL2(RES,LVAL)_$S(NVAL>1:" or ",1:"")
- ... S VALUE=$$TKO^BQIUL1(VALUE," or ")
- ... I ASTR["SETMEAS" D
- .... ;S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1),ASTR=$P(ASTR,"SETMEAS",2)
- .... S ASTR=$P(ASTR,"SETMEAS",2)
- .... NEW LVAL,NVAL,AN
- .... S AN=$O(^BQI(90507.2,"B",VALUE,"")) I AN'="" S RES=$G(^BQI(90507.2,AN,2))
- .... I AN="" S AN=$O(^BQI(90507.2,"C",VALUE,"")) I AN'="" S RES=$G(^BQI(90507.2,AN,2))
- .... S VALUE=VALUE_" is "
- .... S ASTR=$TR(ASTR,$C(28),""),NVAL=$L(ASTR,$C(29))
- .... F I=1:1:NVAL S LVAL=$P(ASTR,$C(29),I) I LVAL'="" S VALUE=VALUE_$$SCD^BQIUL2(RES,LVAL)_$S(NVAL>1:" or ",1:"")
- ... S VALUE=$$TKO^BQIUL1(VALUE," or ")
- .. S FPARMS(PORD,FNAME,$$TRUNC^BQIPDSCM(VALUE))=""
- . ;
- . ;Save multiple values
- . S MN=0 F S MN=$O(^BQICARE(OWNR,1,PLIEN,15,FN,1,MN)) Q:'MN D
- .. NEW DA,IENS,VALUE
- .. S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=FN,DA=MN,IENS=$$IENS^DILF(.DA)
- .. S FNAME=OFNAME
- .. S VALUE=$$GMVAL(PTYP,90505.1151,IENS,FSOURCE,FNAME)
- .. ;
- .. ;Pull associate parameters
- .. S ASTR=$$ASMPARM^BQIPDSCL(MN)
- .. ;
- .. ;Call any defined executable
- .. I VALUE]"",PMAP]"" D MAP^BQIPDSCM(FSOURCE,PMAP,.VALUE,.FNAME)
- .. I VALUE]"",PEXE]"" X PEXE
- .. ;
- .. ;Save multiple value
- .. I VALUE]"" D
- ... I $G(ASTR)="",FNAME="LAB",$G(VALUE)'="",VALUE["^" S VALUE=$P(VALUE,"^",1)
- ... I $G(ASTR)="",FNAME="MEAS",$G(VALUE)'="",VALUE["^" S VALUE=$P(VALUE,"^",1)
- ... I $G(ASTR)'="" D
- .... NEW RES
- .... I ASTR["NUMLAB" D
- ..... S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1)
- ..... S VALUE=VALUE_" is"_$$LBRS^BQIPDSC1(ASTR)
- .... NEW RES
- .... I ASTR["NUMMEAS" D
- ..... S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1)
- ..... S VALUE=VALUE_" is"_$$MSRS^BQIPDSC2(ASTR)
- .... I ASTR["SETLAB" D
- ..... S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1),ASTR=$P(ASTR,"SETLAB",2)
- ..... S VALUE=VALUE_" is "
- ..... NEW LVAL,NVAL
- ..... S ASTR=$TR(ASTR,$C(28),""),NVAL=$L(ASTR,$C(29))
- ..... F I=1:1:NVAL S LVAL=$P(ASTR,$C(29),I) I LVAL'="" S VALUE=VALUE_$$SCD^BQIUL2(RES,LVAL)_$S(NVAL>1:" or ",1:"")
- .... ;S VALUE=$$TKO^BQIUL1(VALUE," or ")
- .... I ASTR["SETMEAS" D
- ..... ;S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1),ASTR=$P(ASTR,"SETMEAS",2)
- ..... S ASTR=$P(ASTR,"SETMEAS",2)
- ..... NEW LVAL,NVAL,AN
- ..... S AN=$O(^BQI(90507.2,"B",VALUE,"")) I AN'="" S RES=$G(^BQI(90507.2,AN,2))
- ..... I AN="" S AN=$O(^BQI(90507.2,"C",VALUE,"")) I AN'="" S RES=$G(^BQI(90507.2,AN,2))
- ..... S VALUE=VALUE_" is "
- ..... S ASTR=$TR(ASTR,$C(28),""),NVAL=$L(ASTR,$C(29))
- ..... F I=1:1:NVAL S LVAL=$P(ASTR,$C(29),I) I LVAL'="" S VALUE=VALUE_$$SCD^BQIUL2(RES,LVAL)_$S(NVAL>1:" or ",1:"")
- .... S VALUE=$$TKO^BQIUL1(VALUE," or ")
- ... S FPARMS(PORD,FNAME,$$TRUNC^BQIPDSCM(VALUE))=""
- Q
- ;
- GVAL(PTYP,FILN,IENS,SRC,NM) ; EP - Get value of parameter/filter
- N VALUE,BQFIL,PEXE,LABR
- ;
- ;Table
- I PTYP="T" D
- . S VALUE=$$GET1^DIQ(FILN,IENS,.03,"E")
- . I VALUE[";" D Q
- .. NEW PGL
- .. S PGL="^"_$P(VALUE,";",2),PGL=$$TKO^BQIUL1(PGL,"(")
- .. S VALUE=$P(@PGL@($P(VALUE,";",1),0),U,1)
- . S BQFIL=$$FILN^BQIDCDF(SRC,NM) Q:BQFIL=""
- . I NM="LAB",VALUE'="" S LABR=$$LSET^BQIDCAH3(VALUE)
- . I NM="MEAS",VALUE'="" S VALUE=$$GET1^DIQ(BQFIL,VALUE_",",.01,"E") Q
- . S VALUE=$$GET1^DIQ(BQFIL,VALUE_",",.01,"E")
- ;
- ;Non-table
- I PTYP'="T" S VALUE=$$GET1^DIQ(FILN,IENS,.02,"E")
- I PTYP="D" S VALUE=$$UP^XLFSTR($$FMTE^XLFDT(VALUE,1))
- I PTYP="R" D
- . ;No longer needs converted
- . ;S VALUE=$$DATE^BQIUL1(VALUE)
- . ;S VALUE=$$UP^XLFSTR($$FMTE^XLFDT(VALUE,1))
- ;
- Q VALUE_$S($G(LABR)'="":"^"_LABR,1:"")
- ;
- GMVAL(PTYP,FILN,IENS,SRC,NM) ; EP - Get value for multiples
- N VALUE,BQFIL,LABR
- I PTYP="T" D
- . S VALUE=$$GET1^DIQ(FILN,IENS,.02,"E")
- . S BQFIL=$$FILN^BQIDCDF(SRC,NM) Q:BQFIL=""
- . I NM="LAB",VALUE'="" S LABR=$$LSET^BQIDCAH3(VALUE)
- . ;I NM="MEAS" Q
- . S VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
- I PTYP'="T" S VALUE=$$GET1^DIQ(FILN,IENS,.01,"E")
- Q VALUE_$S($G(LABR)'="":"^"_LABR,1:"")
- ;
- DLM(FPARMS,FLD) ;EP - Determine delimiter between multiple entries
- NEW PORD,FND,FNAME,FENT
- S (FND,PORD)="" F S PORD=$O(FPARMS(PORD)) Q:'PORD S FNAME="" F S FNAME=$O(FPARMS(PORD,FNAME)) Q:FNAME="" I FNAME=FLD D Q
- . S FENT="" F S FENT=$O(FPARMS(PORD,FNAME,FENT)) Q:FENT="" D
- .. S FPARMS(PORD,FNAME,FENT)=$S($G(VALUE)="&":" AND ",1:" OR ")
- Q
- ;
- AGE ; Format FPARMS("AGE") or FMPARMS("AGE")
- NEW AGE,EXT,OP,AGE1,AGE2
- I '$D(FPARMS(PORD,"AGE")) D Q
- . S AGE=$G(VALUE)
- . S EXT=$S($E(AGE)="'":2,1:1),OP=$E(AGE,1,EXT),AGE=$E(AGE,EXT+1,99)
- . S AGE=$S(OP="=":AGE,OP=">":"older than "_AGE,OP="<":"younger than "_AGE,OP="'<":AGE_" or older",1:AGE_" or younger")
- . I AGE["YRS" S AGE=$P(AGE,"YRS")_" years"_$P(AGE,"YRS",2,99)
- . I AGE["MOS" S AGE=$P(AGE,"MOS")_" months"_$P(AGE,"MOS",2,99)
- . I AGE["DYS" S AGE=$P(AGE,"DYS")_" days"_$P(AGE,"DYS",2,99)
- . S VALUE=AGE
- ;
- ;Two Age values - must be exclusive or inclusive
- S AGE2=$G(VALUE)
- S EXT=$S($E(AGE2)="'":2,1:1),OP=$E(AGE2,1,EXT),AGE2=$E(AGE2,EXT+1,99)
- I AGE2["YRS" S AGE2=$P(AGE2,"YRS")_" years"_$P(AGE2,"YRS",2,99)
- I AGE2["MOS" S AGE2=$P(AGE2,"MOS")_" months"_$P(AGE2,"MOS",2,99)
- I AGE2["DYS" S AGE2=$P(AGE2,"DYS")_" days"_$P(AGE2,"DYS",2,99)
- ;
- ;Inclusive
- S AGE1=$O(FPARMS(PORD,"AGE","")) Q:AGE1=""
- I AGE1["or older"!(AGE1["or younger") D Q
- . K FPARMS(PORD,"AGE",AGE1)
- . I AGE1["or older" S AGE1=$P(AGE1," or older")
- . E S AGE1=$P(AGE1," or younger")
- . S VALUE="between (inclusive) "_AGE1_" and "_AGE2
- ;
- ;Exclusive
- K FPARMS(PORD,"AGE",AGE1)
- I AGE1["younger than" S AGE1=$P(AGE1,"younger than ",2)
- E S AGE1=$P(AGE1,"older than ",2)
- S VALUE="younger than "_AGE1_" or older than "_AGE2
- Q
- ;
- DXCAT ;EP - Diagnosis Category
- NEW I,STR,DXSTAT
- S ASTR=$G(ASTR,"")
- F I=1:1:$L(ASTR,$C(26)) D
- . NEW AINFO,ANAME,AVAL,NVAL,VAL,PC
- . S AINFO=$P(ASTR,$C(26),I)
- . S ANAME=$P(AINFO,$C(28)) Q:ANAME=""
- . S AVAL=$P(AINFO,$C(28),2) Q:AVAL=""
- . S NVAL=""
- . F PC=1:1:$L(AVAL,$C(29)) D
- .. S VAL=$P(AVAL,$C(29),PC) Q:VAL=""
- .. S VAL=$S(VAL="A":"Accepted",VAL="P":"Proposed",VAL="N":"Not Accepted",VAL="V":"No Longer Valid",VAL="S":"Superseded",1:"")
- .. S:VAL]"" NVAL=NVAL_$S(NVAL]"":", ",1:"")_VAL
- . I ANAME]"",NVAL]"" S @ANAME=NVAL
- ;
- S STR="Diagnostic Tag "_VALUE
- S:$G(DXSTAT)]"" STR=STR_" (Diagnostic Tag Status "_DXSTAT_")"
- S VALUE=STR
- Q
- ;
- DEC ;EP - Format Patient status
- ;Save everything under deceased
- S PORD=$$PORD^BQIDCDF(FSOURCE,"DEC") Q:PORD=""
- ;Deceased
- I FNAME="DEC" D
- . NEW PORD,DECDT,DECFDT,DECTDT
- . S VALUE=$S($G(VALUE)="Y":"Deceased",1:"")
- . Q:VALUE=""
- . ;Tack on Deceased information
- . ;Deceased from date
- . S DECFDT=$$GETVAL(OWNR,PLIEN,"DECFDT")
- . I DECFDT]"" S VALUE=VALUE_" (Range from date "_$$FMTE^BQIUL1(DECFDT)
- . ;Deceased thru date
- . S DECTDT=$$GETVAL(OWNR,PLIEN,"DECTDT")
- . I DECTDT]"" S VALUE=VALUE_$S(VALUE["Range":" thru date ",1:" (Range thru date ")_$$FMTE^BQIUL1(DECTDT)
- . I VALUE["(" S VALUE=VALUE_")"
- ;
- ;Living
- I FNAME="LIV" S VALUE=$S($G(VALUE)="Y":"Living",1:"") S:VALUE]"" FNAME="DEC"
- ;
- ;Inactive
- I FNAME="INAC" S VALUE=$S($G(VALUE)="Y":"Inactive",1:"") S:VALUE]"" FNAME="DEC"
- ;
- ;DEMO
- I FNAME="DEMO" S VALUE=$S($G(VALUE)="E":"Exclude",$G(VALUE)="O":"Only",1:"Include")_" DEMO " S:VALUE]"" FNAME="DEC"
- Q
- ;
- PLIDEN ; Format FPARMS("PLIDEN") or FMPARMS("PLIDEN")
- Q:$G(VALUE)=""
- ;
- NEW PLOWNR,PLNAME
- S PLOWNR=$P(VALUE,$C(26)) S:PLOWNR]"" PLOWNR=$$GET1^DIQ(200,PLOWNR_",",.01,"E")
- S:PLOWNR]"" PLOWNR="(Owner: "_PLOWNR_")"
- S PLNAME=$P(VALUE,$C(26),2)
- ;
- S VALUE=PLNAME_$S(PLNAME]"":" ",1:"")_PLOWNR
- Q
- I $D(FPARMS("PLIDEN")) D
- . S PLOWNR=$P(FPARMS("PLIDEN"),$C(26),1),PLOWNR=$$GET1^DIQ(200,PLOWNR_",",.01,"E")
- . S FPARMS("PLIDEN")=$P(FPARMS("PLIDEN"),$C(26),2)_" "_PLOWNR
- I $D(FMPARMS("PLIDEN")) D
- . N PLIEN,PLARR
- . S PLIEN=""
- . F S PLIEN=$O(FMPARMS("PLIDEN",PLIEN)) Q:PLIEN="" D
- .. S PLOWNR=$P(PLIEN,$C(26),1),PLOWNR=$$GET1^DIQ(200,PLOWNR_",",.01,"E")
- .. S PLARR($P(PLIEN,$C(26),2)_" "_PLOWNR)=""
- . K FMPARMS("PLIDEN")
- . M FMPARMS("PLIDEN")=PLARR
- Q
- ;
- LABTX(VALUE) ;EP - Assemble LABTX value
- NEW X,DIC,Y,IEN,VAL,LABTST,LTST
- I VALUE="" Q
- S X=VALUE,DIC="^ATXLAB(" D ^DIC
- S VALUE="Lab Taxonomy "_VALUE
- I Y="-1" Q
- S IEN=+Y_",",VAL=""
- D GETS^DIQ(9002228,IEN,"2101*","E","LABTST")
- S LTST="" F S LTST=$O(LABTST(9002228.02101,LTST)) Q:LTST="" D
- . S VAL=VAL_$S(VAL="":" (Lab Tests ",1:", ")_$G(LABTST(9002228.02101,LTST,".01","E"))
- S:VAL["(" VAL=VAL_")"
- S VALUE=VALUE_VAL
- Q
- ;
- MEDTX(VALUE) ;EP - Assemble MEDTX value
- NEW X,DIC,Y,IEN,VAL,MED,MTST,MD,FILE
- I VALUE="" Q
- S X=VALUE,DIC="^ATXAX(" D ^DIC
- S VALUE="Medication Taxonomy "_VALUE
- I Y="-1" Q
- S IEN=+Y_",",VAL=""
- D GETS^DIQ(9002226,IEN,".15;2101*","IE","MED")
- S FILE=$G(MED(9002226,IEN,.15,"I")) Q:FILE=""
- S MTST="" F S MTST=$O(MED(9002226.02101,MTST)) Q:MTST="" D
- . S MD=$G(MED(9002226.02101,MTST,".01","E")) Q:MD=""
- . S MD=$$GET1^DIQ(FILE,MD_",",.01,"E")
- . S VAL=VAL_$S(VAL="":" (Medications ",1:", ")_MD
- S:VAL["(" VAL=VAL_")"
- S VALUE=VALUE_VAL
- Q
- ;
- PRBTX(VALUE) ;EP - Assemble PROBTX value
- NEW X,DIC,Y,IEN,VAL,PROB,PTST,PB,FILE
- I VALUE="" Q
- S X=VALUE,DIC="^ATXAX(" D ^DIC
- S VALUE="Problem Taxonomy "_VALUE
- I Y="-1" Q
- S IEN=+Y_",",VAL=" ("
- D GETS^DIQ(9002226,IEN,".15;2101*","IE","PROB")
- S FILE=$G(PROB(9002226,IEN,.15,"I")) Q:FILE=""
- S PTST="" F S PTST=$O(PROB(9002226.02101,PTST)) Q:PTST="" D
- . S PB=$G(PROB(9002226.02101,PTST,".01","E")) Q:PB=""
- . S VAL=VAL_$$TKO^BQIUL1(PB," ")_", "
- S VAL=$$TKO^BQIUL1(VAL,", ")
- S:VAL["(" VAL=VAL_")"
- S VALUE=VALUE_VAL
- Q
- ;
- GETVAL(OWNR,PLIEN,FLD) ;EP - Retrieve Single field value
- N DECIEN,DA,IEN,IENS
- S IEN=$O(^BQICARE(OWNR,1,PLIEN,15,"B",FLD,"")) Q:IEN="" ""
- S DA(2)=OWNR,DA(1)=PLIEN,DA=IEN,IENS=$$IENS^DILF(.DA)
- Q $$GET1^DIQ(90505.115,IENS,.02,"I")
- ;
- ICD(ICDIEN) ;EP - Return ICD Information
- NEW ICD
- S ICD=""
- ;Pull appropriate ICD-9/ICD-10 code
- ;ICD-9
- I $$VERSION^XPDUTL("AICD")<4.0 D
- . NEW STR
- . I '$L($T(ICDDX^ICDCODE)) D Q
- .. S ICD=$$GET1^DIQ(80,ICDIEN_",",.03,"I")_U_$$GET1^DIQ(80,ICDIEN_",",.01,"I")
- . S STR=$$ICDDX^ICDCODE(ICDIEN) I $P(STR,U)="-1" Q
- . S ICD=$P(STR,U,4)_U_$P(STR,U,2)
- ;
- ;ICD-9 or ICD-10
- I $$VERSION^XPDUTL("AICD")>3.51 D
- . ;First try to locate ICD-10
- . I $$IMP^ICDEXA(30)'>DT D Q:ICD]""
- .. NEW STR
- .. S STR=$$ICDDATA^ICDXCODE(30,ICDIEN,DT,"E") I $P(STR,U)="-1" Q
- .. S ICD=$P(STR,U,4)_U_$P(STR,U,2)
- . ;If not an ICD-10 code try ICD-9 (could be before date or a historical entry)
- . I $G(ICD)="" D
- .. NEW STR
- .. S STR=$$ICDDATA^ICDXCODE(1,ICDIEN,DT,"E") I $P(STR,U)="-1" Q
- .. S ICD=$P(STR,U,4)_U_$P(STR,U,2)
- Q $S(ICD]"":($P(ICD,U)_" ("_$P(ICD,U,2)_")"),1:"")
- ;
- PRST(VALUE) ;EP - Problem statuses
- NEW FILE,FLD
- S FILE=9000011,FLD=.12
- S VALUE=$$STC^BQIUL2(FILE,FLD,VALUE)
- Q
- BQIPDSCF ;VNGT/HS/BEE-Panel Description Utility ; 7 Apr 2008 4:28 PM
- +1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
- +2 ;
- FILTER(OWNR,PLIEN,FPARMS) ;EP - Include filter description
- +1 ;
- +2 ; Retrieve all filters for this panel and return as a string in filter order
- +3 ; as defined in the ICARE DEFINITIONS file (90506.03,.1)
- +4 ;
- +5 NEW DA,FIEN,FIENS,FSOURCE,FN,MN
- +6 ;
- +7 SET DA(1)=OWNR
- SET DA=PLIEN
- SET FIENS=$$IENS^DILF(.DA)
- +8 SET FSOURCE=$$GET1^DIQ(90505.01,FIENS,.14,"E")
- +9 ;
- +10 ;Quit if filter turned off
- +11 IF FSOURCE=""
- QUIT ""
- +12 ;
- +13 ; Filter ien
- SET FIEN=$$PP^BQIDCDF(FSOURCE)
- +14 IF FIEN=-1
- SET BMXSEC="Filter SOURCE was not found"
- QUIT ""
- +15 ;
- +16 ;Get each filter from panel definition
- +17 SET FN=0
- FOR
- SET FN=$ORDER(^BQICARE(OWNR,1,PLIEN,15,FN))
- IF 'FN
- QUIT
- Begin DoDot:1
- +18 NEW DA,IENS,FNAME,VALUE,PEXE,PTYP,PORD,VALUE,ASTR,PMAP,OFNAME
- +19 SET DA(2)=OWNR
- SET DA(1)=PLIEN
- SET DA=FN
- SET IENS=$$IENS^DILF(.DA)
- +20 SET (OFNAME,FNAME)=$$GET1^DIQ(90505.115,IENS,.01,"E")
- IF FNAME=""
- QUIT
- +21 SET PTYP=$$PTYP^BQIDCDF(FSOURCE,FNAME)
- IF PTYP=""
- QUIT
- +22 SET PORD=$$PORD^BQIDCDF(FSOURCE,FNAME)
- IF PORD=""
- QUIT
- +23 SET VALUE=$$GVAL(PTYP,90505.115,IENS,FSOURCE,FNAME)
- +24 ;
- +25 ;Pull associate parameters
- +26 SET ASTR=$$ASPARM^BQIPDSCL(FN)
- +27 ;
- +28 ;Call any defined executable
- +29 SET PMAP=$$PMAP^BQIDCDF(FSOURCE,FNAME)
- IF VALUE]""
- IF PMAP]""
- DO MAP^BQIPDSCM(FSOURCE,PMAP,.VALUE,.FNAME)
- +30 SET PEXE=$$PEXE^BQIDCDF(FSOURCE,FNAME)
- IF VALUE]""
- IF PEXE]""
- XECUTE PEXE
- +31 ;
- +32 ;Save single value
- +33 IF VALUE]""
- Begin DoDot:2
- +34 IF $GET(ASTR)=""
- IF FNAME="LAB"
- IF $GET(VALUE)'=""
- IF VALUE["^"
- SET VALUE=$PIECE(VALUE,"^",1)
- +35 IF $GET(ASTR)=""
- IF FNAME="MEAS"
- IF $GET(VALUE)'=""
- IF VALUE["^"
- SET VALUE=$PIECE(VALUE,"^",1)
- +36 IF $GET(ASTR)'=""
- Begin DoDot:3
- +37 NEW RES
- +38 IF ASTR["NUMLAB"
- Begin DoDot:4
- +39 SET RES=$PIECE(VALUE,U,2)
- SET VALUE=$PIECE(VALUE,U,1)
- +40 SET VALUE=VALUE_" is"_$$LBRS^BQIPDSC1(ASTR)
- End DoDot:4
- +41 NEW RES
- +42 IF ASTR["NUMMEAS"
- Begin DoDot:4
- +43 SET RES=$PIECE(VALUE,U,2)
- SET VALUE=$PIECE(VALUE,U,1)
- +44 SET VALUE=VALUE_" is"_$$MSRS^BQIPDSC2(ASTR)
- End DoDot:4
- +45 IF ASTR["SETLAB"
- Begin DoDot:4
- +46 SET RES=$PIECE(VALUE,U,2)
- SET VALUE=$PIECE(VALUE,U,1)
- SET ASTR=$PIECE(ASTR,"SETLAB",2)
- +47 NEW LVAL,NVAL
- +48 SET VALUE=VALUE_" is "
- +49 SET ASTR=$TRANSLATE(ASTR,$CHAR(28),"")
- SET NVAL=$LENGTH(ASTR,$CHAR(29))
- +50 FOR I=1:1:NVAL
- SET LVAL=$PIECE(ASTR,$CHAR(29),I)
- IF LVAL'=""
- SET VALUE=VALUE_$$SCD^BQIUL2(RES,LVAL)_$SELECT(NVAL>1:" or ",1:"")
- End DoDot:4
- +51 SET VALUE=$$TKO^BQIUL1(VALUE," or ")
- +52 IF ASTR["SETMEAS"
- Begin DoDot:4
- +53 ;S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1),ASTR=$P(ASTR,"SETMEAS",2)
- +54 SET ASTR=$PIECE(ASTR,"SETMEAS",2)
- +55 NEW LVAL,NVAL,AN
- +56 SET AN=$ORDER(^BQI(90507.2,"B",VALUE,""))
- IF AN'=""
- SET RES=$GET(^BQI(90507.2,AN,2))
- +57 IF AN=""
- SET AN=$ORDER(^BQI(90507.2,"C",VALUE,""))
- IF AN'=""
- SET RES=$GET(^BQI(90507.2,AN,2))
- +58 SET VALUE=VALUE_" is "
- +59 SET ASTR=$TRANSLATE(ASTR,$CHAR(28),"")
- SET NVAL=$LENGTH(ASTR,$CHAR(29))
- +60 FOR I=1:1:NVAL
- SET LVAL=$PIECE(ASTR,$CHAR(29),I)
- IF LVAL'=""
- SET VALUE=VALUE_$$SCD^BQIUL2(RES,LVAL)_$SELECT(NVAL>1:" or ",1:"")
- End DoDot:4
- +61 SET VALUE=$$TKO^BQIUL1(VALUE," or ")
- End DoDot:3
- +62 SET FPARMS(PORD,FNAME,$$TRUNC^BQIPDSCM(VALUE))=""
- End DoDot:2
- QUIT
- +63 ;
- +64 ;Save multiple values
- +65 SET MN=0
- FOR
- SET MN=$ORDER(^BQICARE(OWNR,1,PLIEN,15,FN,1,MN))
- IF 'MN
- QUIT
- Begin DoDot:2
- +66 NEW DA,IENS,VALUE
- +67 SET DA(3)=OWNR
- SET DA(2)=PLIEN
- SET DA(1)=FN
- SET DA=MN
- SET IENS=$$IENS^DILF(.DA)
- +68 SET FNAME=OFNAME
- +69 SET VALUE=$$GMVAL(PTYP,90505.1151,IENS,FSOURCE,FNAME)
- +70 ;
- +71 ;Pull associate parameters
- +72 SET ASTR=$$ASMPARM^BQIPDSCL(MN)
- +73 ;
- +74 ;Call any defined executable
- +75 IF VALUE]""
- IF PMAP]""
- DO MAP^BQIPDSCM(FSOURCE,PMAP,.VALUE,.FNAME)
- +76 IF VALUE]""
- IF PEXE]""
- XECUTE PEXE
- +77 ;
- +78 ;Save multiple value
- +79 IF VALUE]""
- Begin DoDot:3
- +80 IF $GET(ASTR)=""
- IF FNAME="LAB"
- IF $GET(VALUE)'=""
- IF VALUE["^"
- SET VALUE=$PIECE(VALUE,"^",1)
- +81 IF $GET(ASTR)=""
- IF FNAME="MEAS"
- IF $GET(VALUE)'=""
- IF VALUE["^"
- SET VALUE=$PIECE(VALUE,"^",1)
- +82 IF $GET(ASTR)'=""
- Begin DoDot:4
- +83 NEW RES
- +84 IF ASTR["NUMLAB"
- Begin DoDot:5
- +85 SET RES=$PIECE(VALUE,U,2)
- SET VALUE=$PIECE(VALUE,U,1)
- +86 SET VALUE=VALUE_" is"_$$LBRS^BQIPDSC1(ASTR)
- End DoDot:5
- +87 NEW RES
- +88 IF ASTR["NUMMEAS"
- Begin DoDot:5
- +89 SET RES=$PIECE(VALUE,U,2)
- SET VALUE=$PIECE(VALUE,U,1)
- +90 SET VALUE=VALUE_" is"_$$MSRS^BQIPDSC2(ASTR)
- End DoDot:5
- +91 IF ASTR["SETLAB"
- Begin DoDot:5
- +92 SET RES=$PIECE(VALUE,U,2)
- SET VALUE=$PIECE(VALUE,U,1)
- SET ASTR=$PIECE(ASTR,"SETLAB",2)
- +93 SET VALUE=VALUE_" is "
- +94 NEW LVAL,NVAL
- +95 SET ASTR=$TRANSLATE(ASTR,$CHAR(28),"")
- SET NVAL=$LENGTH(ASTR,$CHAR(29))
- +96 FOR I=1:1:NVAL
- SET LVAL=$PIECE(ASTR,$CHAR(29),I)
- IF LVAL'=""
- SET VALUE=VALUE_$$SCD^BQIUL2(RES,LVAL)_$SELECT(NVAL>1:" or ",1:"")
- End DoDot:5
- +97 ;S VALUE=$$TKO^BQIUL1(VALUE," or ")
- +98 IF ASTR["SETMEAS"
- Begin DoDot:5
- +99 ;S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1),ASTR=$P(ASTR,"SETMEAS",2)
- +100 SET ASTR=$PIECE(ASTR,"SETMEAS",2)
- +101 NEW LVAL,NVAL,AN
- +102 SET AN=$ORDER(^BQI(90507.2,"B",VALUE,""))
- IF AN'=""
- SET RES=$GET(^BQI(90507.2,AN,2))
- +103 IF AN=""
- SET AN=$ORDER(^BQI(90507.2,"C",VALUE,""))
- IF AN'=""
- SET RES=$GET(^BQI(90507.2,AN,2))
- +104 SET VALUE=VALUE_" is "
- +105 SET ASTR=$TRANSLATE(ASTR,$CHAR(28),"")
- SET NVAL=$LENGTH(ASTR,$CHAR(29))
- +106 FOR I=1:1:NVAL
- SET LVAL=$PIECE(ASTR,$CHAR(29),I)
- IF LVAL'=""
- SET VALUE=VALUE_$$SCD^BQIUL2(RES,LVAL)_$SELECT(NVAL>1:" or ",1:"")
- End DoDot:5
- +107 SET VALUE=$$TKO^BQIUL1(VALUE," or ")
- End DoDot:4
- +108 SET FPARMS(PORD,FNAME,$$TRUNC^BQIPDSCM(VALUE))=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +109 QUIT
- +110 ;
- GVAL(PTYP,FILN,IENS,SRC,NM) ; EP - Get value of parameter/filter
- +1 NEW VALUE,BQFIL,PEXE,LABR
- +2 ;
- +3 ;Table
- +4 IF PTYP="T"
- Begin DoDot:1
- +5 SET VALUE=$$GET1^DIQ(FILN,IENS,.03,"E")
- +6 IF VALUE[";"
- Begin DoDot:2
- +7 NEW PGL
- +8 SET PGL="^"_$PIECE(VALUE,";",2)
- SET PGL=$$TKO^BQIUL1(PGL,"(")
- +9 SET VALUE=$PIECE(@PGL@($PIECE(VALUE,";",1),0),U,1)
- End DoDot:2
- QUIT
- +10 SET BQFIL=$$FILN^BQIDCDF(SRC,NM)
- IF BQFIL=""
- QUIT
- +11 IF NM="LAB"
- IF VALUE'=""
- SET LABR=$$LSET^BQIDCAH3(VALUE)
- +12 IF NM="MEAS"
- IF VALUE'=""
- SET VALUE=$$GET1^DIQ(BQFIL,VALUE_",",.01,"E")
- QUIT
- +13 SET VALUE=$$GET1^DIQ(BQFIL,VALUE_",",.01,"E")
- End DoDot:1
- +14 ;
- +15 ;Non-table
- +16 IF PTYP'="T"
- SET VALUE=$$GET1^DIQ(FILN,IENS,.02,"E")
- +17 IF PTYP="D"
- SET VALUE=$$UP^XLFSTR($$FMTE^XLFDT(VALUE,1))
- +18 IF PTYP="R"
- Begin DoDot:1
- +19 ;No longer needs converted
- +20 ;S VALUE=$$DATE^BQIUL1(VALUE)
- +21 ;S VALUE=$$UP^XLFSTR($$FMTE^XLFDT(VALUE,1))
- End DoDot:1
- +22 ;
- +23 QUIT VALUE_$SELECT($GET(LABR)'="":"^"_LABR,1:"")
- +24 ;
- GMVAL(PTYP,FILN,IENS,SRC,NM) ; EP - Get value for multiples
- +1 NEW VALUE,BQFIL,LABR
- +2 IF PTYP="T"
- Begin DoDot:1
- +3 SET VALUE=$$GET1^DIQ(FILN,IENS,.02,"E")
- +4 SET BQFIL=$$FILN^BQIDCDF(SRC,NM)
- IF BQFIL=""
- QUIT
- +5 IF NM="LAB"
- IF VALUE'=""
- SET LABR=$$LSET^BQIDCAH3(VALUE)
- +6 ;I NM="MEAS" Q
- +7 SET VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
- End DoDot:1
- +8 IF PTYP'="T"
- SET VALUE=$$GET1^DIQ(FILN,IENS,.01,"E")
- +9 QUIT VALUE_$SELECT($GET(LABR)'="":"^"_LABR,1:"")
- +10 ;
- DLM(FPARMS,FLD) ;EP - Determine delimiter between multiple entries
- +1 NEW PORD,FND,FNAME,FENT
- +2 SET (FND,PORD)=""
- FOR
- SET PORD=$ORDER(FPARMS(PORD))
- IF 'PORD
- QUIT
- SET FNAME=""
- FOR
- SET FNAME=$ORDER(FPARMS(PORD,FNAME))
- IF FNAME=""
- QUIT
- IF FNAME=FLD
- Begin DoDot:1
- +3 SET FENT=""
- FOR
- SET FENT=$ORDER(FPARMS(PORD,FNAME,FENT))
- IF FENT=""
- QUIT
- Begin DoDot:2
- +4 SET FPARMS(PORD,FNAME,FENT)=$SELECT($GET(VALUE)="&":" AND ",1:" OR ")
- End DoDot:2
- End DoDot:1
- QUIT
- +5 QUIT
- +6 ;
- AGE ; Format FPARMS("AGE") or FMPARMS("AGE")
- +1 NEW AGE,EXT,OP,AGE1,AGE2
- +2 IF '$DATA(FPARMS(PORD,"AGE"))
- Begin DoDot:1
- +3 SET AGE=$GET(VALUE)
- +4 SET EXT=$SELECT($EXTRACT(AGE)="'":2,1:1)
- SET OP=$EXTRACT(AGE,1,EXT)
- SET AGE=$EXTRACT(AGE,EXT+1,99)
- +5 SET AGE=$SELECT(OP="=":AGE,OP=">":"older than "_AGE,OP="<":"younger than "_AGE,OP="'<":AGE_" or older",1:AGE_" or younger")
- +6 IF AGE["YRS"
- SET AGE=$PIECE(AGE,"YRS")_" years"_$PIECE(AGE,"YRS",2,99)
- +7 IF AGE["MOS"
- SET AGE=$PIECE(AGE,"MOS")_" months"_$PIECE(AGE,"MOS",2,99)
- +8 IF AGE["DYS"
- SET AGE=$PIECE(AGE,"DYS")_" days"_$PIECE(AGE,"DYS",2,99)
- +9 SET VALUE=AGE
- End DoDot:1
- QUIT
- +10 ;
- +11 ;Two Age values - must be exclusive or inclusive
- +12 SET AGE2=$GET(VALUE)
- +13 SET EXT=$SELECT($EXTRACT(AGE2)="'":2,1:1)
- SET OP=$EXTRACT(AGE2,1,EXT)
- SET AGE2=$EXTRACT(AGE2,EXT+1,99)
- +14 IF AGE2["YRS"
- SET AGE2=$PIECE(AGE2,"YRS")_" years"_$PIECE(AGE2,"YRS",2,99)
- +15 IF AGE2["MOS"
- SET AGE2=$PIECE(AGE2,"MOS")_" months"_$PIECE(AGE2,"MOS",2,99)
- +16 IF AGE2["DYS"
- SET AGE2=$PIECE(AGE2,"DYS")_" days"_$PIECE(AGE2,"DYS",2,99)
- +17 ;
- +18 ;Inclusive
- +19 SET AGE1=$ORDER(FPARMS(PORD,"AGE",""))
- IF AGE1=""
- QUIT
- +20 IF AGE1["or older"!(AGE1["or younger")
- Begin DoDot:1
- +21 KILL FPARMS(PORD,"AGE",AGE1)
- +22 IF AGE1["or older"
- SET AGE1=$PIECE(AGE1," or older")
- +23 IF '$TEST
- SET AGE1=$PIECE(AGE1," or younger")
- +24 SET VALUE="between (inclusive) "_AGE1_" and "_AGE2
- End DoDot:1
- QUIT
- +25 ;
- +26 ;Exclusive
- +27 KILL FPARMS(PORD,"AGE",AGE1)
- +28 IF AGE1["younger than"
- SET AGE1=$PIECE(AGE1,"younger than ",2)
- +29 IF '$TEST
- SET AGE1=$PIECE(AGE1,"older than ",2)
- +30 SET VALUE="younger than "_AGE1_" or older than "_AGE2
- +31 QUIT
- +32 ;
- DXCAT ;EP - Diagnosis Category
- +1 NEW I,STR,DXSTAT
- +2 SET ASTR=$GET(ASTR,"")
- +3 FOR I=1:1:$LENGTH(ASTR,$CHAR(26))
- Begin DoDot:1
- +4 NEW AINFO,ANAME,AVAL,NVAL,VAL,PC
- +5 SET AINFO=$PIECE(ASTR,$CHAR(26),I)
- +6 SET ANAME=$PIECE(AINFO,$CHAR(28))
- IF ANAME=""
- QUIT
- +7 SET AVAL=$PIECE(AINFO,$CHAR(28),2)
- IF AVAL=""
- QUIT
- +8 SET NVAL=""
- +9 FOR PC=1:1:$LENGTH(AVAL,$CHAR(29))
- Begin DoDot:2
- +10 SET VAL=$PIECE(AVAL,$CHAR(29),PC)
- IF VAL=""
- QUIT
- +11 SET VAL=$SELECT(VAL="A":"Accepted",VAL="P":"Proposed",VAL="N":"Not Accepted",VAL="V":"No Longer Valid",VAL="S":"Superseded",1:"")
- +12 IF VAL]""
- SET NVAL=NVAL_$SELECT(NVAL]"":", ",1:"")_VAL
- End DoDot:2
- +13 IF ANAME]""
- IF NVAL]""
- SET @ANAME=NVAL
- End DoDot:1
- +14 ;
- +15 SET STR="Diagnostic Tag "_VALUE
- +16 IF $GET(DXSTAT)]""
- SET STR=STR_" (Diagnostic Tag Status "_DXSTAT_")"
- +17 SET VALUE=STR
- +18 QUIT
- +19 ;
- DEC ;EP - Format Patient status
- +1 ;Save everything under deceased
- +2 SET PORD=$$PORD^BQIDCDF(FSOURCE,"DEC")
- IF PORD=""
- QUIT
- +3 ;Deceased
- +4 IF FNAME="DEC"
- Begin DoDot:1
- +5 NEW PORD,DECDT,DECFDT,DECTDT
- +6 SET VALUE=$SELECT($GET(VALUE)="Y":"Deceased",1:"")
- +7 IF VALUE=""
- QUIT
- +8 ;Tack on Deceased information
- +9 ;Deceased from date
- +10 SET DECFDT=$$GETVAL(OWNR,PLIEN,"DECFDT")
- +11 IF DECFDT]""
- SET VALUE=VALUE_" (Range from date "_$$FMTE^BQIUL1(DECFDT)
- +12 ;Deceased thru date
- +13 SET DECTDT=$$GETVAL(OWNR,PLIEN,"DECTDT")
- +14 IF DECTDT]""
- SET VALUE=VALUE_$SELECT(VALUE["Range":" thru date ",1:" (Range thru date ")_$$FMTE^BQIUL1(DECTDT)
- +15 IF VALUE["("
- SET VALUE=VALUE_")"
- End DoDot:1
- +16 ;
- +17 ;Living
- +18 IF FNAME="LIV"
- SET VALUE=$SELECT($GET(VALUE)="Y":"Living",1:"")
- IF VALUE]""
- SET FNAME="DEC"
- +19 ;
- +20 ;Inactive
- +21 IF FNAME="INAC"
- SET VALUE=$SELECT($GET(VALUE)="Y":"Inactive",1:"")
- IF VALUE]""
- SET FNAME="DEC"
- +22 ;
- +23 ;DEMO
- +24 IF FNAME="DEMO"
- SET VALUE=$SELECT($GET(VALUE)="E":"Exclude",$GET(VALUE)="O":"Only",1:"Include")_" DEMO "
- IF VALUE]""
- SET FNAME="DEC"
- +25 QUIT
- +26 ;
- PLIDEN ; Format FPARMS("PLIDEN") or FMPARMS("PLIDEN")
- +1 IF $GET(VALUE)=""
- QUIT
- +2 ;
- +3 NEW PLOWNR,PLNAME
- +4 SET PLOWNR=$PIECE(VALUE,$CHAR(26))
- IF PLOWNR]""
- SET PLOWNR=$$GET1^DIQ(200,PLOWNR_",",.01,"E")
- +5 IF PLOWNR]""
- SET PLOWNR="(Owner: "_PLOWNR_")"
- +6 SET PLNAME=$PIECE(VALUE,$CHAR(26),2)
- +7 ;
- +8 SET VALUE=PLNAME_$SELECT(PLNAME]"":" ",1:"")_PLOWNR
- +9 QUIT
- +10 IF $DATA(FPARMS("PLIDEN"))
- Begin DoDot:1
- +11 SET PLOWNR=$PIECE(FPARMS("PLIDEN"),$CHAR(26),1)
- SET PLOWNR=$$GET1^DIQ(200,PLOWNR_",",.01,"E")
- +12 SET FPARMS("PLIDEN")=$PIECE(FPARMS("PLIDEN"),$CHAR(26),2)_" "_PLOWNR
- End DoDot:1
- +13 IF $DATA(FMPARMS("PLIDEN"))
- Begin DoDot:1
- +14 NEW PLIEN,PLARR
- +15 SET PLIEN=""
- +16 FOR
- SET PLIEN=$ORDER(FMPARMS("PLIDEN",PLIEN))
- IF PLIEN=""
- QUIT
- Begin DoDot:2
- +17 SET PLOWNR=$PIECE(PLIEN,$CHAR(26),1)
- SET PLOWNR=$$GET1^DIQ(200,PLOWNR_",",.01,"E")
- +18 SET PLARR($PIECE(PLIEN,$CHAR(26),2)_" "_PLOWNR)=""
- End DoDot:2
- +19 KILL FMPARMS("PLIDEN")
- +20 MERGE FMPARMS("PLIDEN")=PLARR
- End DoDot:1
- +21 QUIT
- +22 ;
- LABTX(VALUE) ;EP - Assemble LABTX value
- +1 NEW X,DIC,Y,IEN,VAL,LABTST,LTST
- +2 IF VALUE=""
- QUIT
- +3 SET X=VALUE
- SET DIC="^ATXLAB("
- DO ^DIC
- +4 SET VALUE="Lab Taxonomy "_VALUE
- +5 IF Y="-1"
- QUIT
- +6 SET IEN=+Y_","
- SET VAL=""
- +7 DO GETS^DIQ(9002228,IEN,"2101*","E","LABTST")
- +8 SET LTST=""
- FOR
- SET LTST=$ORDER(LABTST(9002228.02101,LTST))
- IF LTST=""
- QUIT
- Begin DoDot:1
- +9 SET VAL=VAL_$SELECT(VAL="":" (Lab Tests ",1:", ")_$GET(LABTST(9002228.02101,LTST,".01","E"))
- End DoDot:1
- +10 IF VAL["("
- SET VAL=VAL_")"
- +11 SET VALUE=VALUE_VAL
- +12 QUIT
- +13 ;
- MEDTX(VALUE) ;EP - Assemble MEDTX value
- +1 NEW X,DIC,Y,IEN,VAL,MED,MTST,MD,FILE
- +2 IF VALUE=""
- QUIT
- +3 SET X=VALUE
- SET DIC="^ATXAX("
- DO ^DIC
- +4 SET VALUE="Medication Taxonomy "_VALUE
- +5 IF Y="-1"
- QUIT
- +6 SET IEN=+Y_","
- SET VAL=""
- +7 DO GETS^DIQ(9002226,IEN,".15;2101*","IE","MED")
- +8 SET FILE=$GET(MED(9002226,IEN,.15,"I"))
- IF FILE=""
- QUIT
- +9 SET MTST=""
- FOR
- SET MTST=$ORDER(MED(9002226.02101,MTST))
- IF MTST=""
- QUIT
- Begin DoDot:1
- +10 SET MD=$GET(MED(9002226.02101,MTST,".01","E"))
- IF MD=""
- QUIT
- +11 SET MD=$$GET1^DIQ(FILE,MD_",",.01,"E")
- +12 SET VAL=VAL_$SELECT(VAL="":" (Medications ",1:", ")_MD
- End DoDot:1
- +13 IF VAL["("
- SET VAL=VAL_")"
- +14 SET VALUE=VALUE_VAL
- +15 QUIT
- +16 ;
- PRBTX(VALUE) ;EP - Assemble PROBTX value
- +1 NEW X,DIC,Y,IEN,VAL,PROB,PTST,PB,FILE
- +2 IF VALUE=""
- QUIT
- +3 SET X=VALUE
- SET DIC="^ATXAX("
- DO ^DIC
- +4 SET VALUE="Problem Taxonomy "_VALUE
- +5 IF Y="-1"
- QUIT
- +6 SET IEN=+Y_","
- SET VAL=" ("
- +7 DO GETS^DIQ(9002226,IEN,".15;2101*","IE","PROB")
- +8 SET FILE=$GET(PROB(9002226,IEN,.15,"I"))
- IF FILE=""
- QUIT
- +9 SET PTST=""
- FOR
- SET PTST=$ORDER(PROB(9002226.02101,PTST))
- IF PTST=""
- QUIT
- Begin DoDot:1
- +10 SET PB=$GET(PROB(9002226.02101,PTST,".01","E"))
- IF PB=""
- QUIT
- +11 SET VAL=VAL_$$TKO^BQIUL1(PB," ")_", "
- End DoDot:1
- +12 SET VAL=$$TKO^BQIUL1(VAL,", ")
- +13 IF VAL["("
- SET VAL=VAL_")"
- +14 SET VALUE=VALUE_VAL
- +15 QUIT
- +16 ;
- GETVAL(OWNR,PLIEN,FLD) ;EP - Retrieve Single field value
- +1 NEW DECIEN,DA,IEN,IENS
- +2 SET IEN=$ORDER(^BQICARE(OWNR,1,PLIEN,15,"B",FLD,""))
- IF IEN=""
- QUIT ""
- +3 SET DA(2)=OWNR
- SET DA(1)=PLIEN
- SET DA=IEN
- SET IENS=$$IENS^DILF(.DA)
- +4 QUIT $$GET1^DIQ(90505.115,IENS,.02,"I")
- +5 ;
- ICD(ICDIEN) ;EP - Return ICD Information
- +1 NEW ICD
- +2 SET ICD=""
- +3 ;Pull appropriate ICD-9/ICD-10 code
- +4 ;ICD-9
- +5 IF $$VERSION^XPDUTL("AICD")<4.0
- Begin DoDot:1
- +6 NEW STR
- +7 IF '$LENGTH($TEXT(ICDDX^ICDCODE))
- Begin DoDot:2
- +8 SET ICD=$$GET1^DIQ(80,ICDIEN_",",.03,"I")_U_$$GET1^DIQ(80,ICDIEN_",",.01,"I")
- End DoDot:2
- QUIT
- +9 SET STR=$$ICDDX^ICDCODE(ICDIEN)
- IF $PIECE(STR,U)="-1"
- QUIT
- +10 SET ICD=$PIECE(STR,U,4)_U_$PIECE(STR,U,2)
- End DoDot:1
- +11 ;
- +12 ;ICD-9 or ICD-10
- +13 IF $$VERSION^XPDUTL("AICD")>3.51
- Begin DoDot:1
- +14 ;First try to locate ICD-10
- +15 IF $$IMP^ICDEXA(30)'>DT
- Begin DoDot:2
- +16 NEW STR
- +17 SET STR=$$ICDDATA^ICDXCODE(30,ICDIEN,DT,"E")
- IF $PIECE(STR,U)="-1"
- QUIT
- +18 SET ICD=$PIECE(STR,U,4)_U_$PIECE(STR,U,2)
- End DoDot:2
- IF ICD]""
- QUIT
- +19 ;If not an ICD-10 code try ICD-9 (could be before date or a historical entry)
- +20 IF $GET(ICD)=""
- Begin DoDot:2
- +21 NEW STR
- +22 SET STR=$$ICDDATA^ICDXCODE(1,ICDIEN,DT,"E")
- IF $PIECE(STR,U)="-1"
- QUIT
- +23 SET ICD=$PIECE(STR,U,4)_U_$PIECE(STR,U,2)
- End DoDot:2
- End DoDot:1
- +24 QUIT $SELECT(ICD]"":($PIECE(ICD,U)_" ("_$PIECE(ICD,U,2)_")"),1:"")
- +25 ;
- PRST(VALUE) ;EP - Problem statuses
- +1 NEW FILE,FLD
- +2 SET FILE=9000011
- SET FLD=.12
- +3 SET VALUE=$$STC^BQIUL2(FILE,FLD,VALUE)
- +4 QUIT