Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQIPDSCF

BQIPDSCF.m

Go to the documentation of this file.
  1. BQIPDSCF ;VNGT/HS/BEE-Panel Description Utility ; 7 Apr 2008 4:28 PM
  1. ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1. ;
  1. FILTER(OWNR,PLIEN,FPARMS) ;EP - Include filter description
  1. ;
  1. ; Retrieve all filters for this panel and return as a string in filter order
  1. ; as defined in the ICARE DEFINITIONS file (90506.03,.1)
  1. ;
  1. N DA,FIEN,FIENS,FSOURCE,FN,MN
  1. ;
  1. S DA(1)=OWNR,DA=PLIEN,FIENS=$$IENS^DILF(.DA)
  1. S FSOURCE=$$GET1^DIQ(90505.01,FIENS,.14,"E")
  1. ;
  1. ;Quit if filter turned off
  1. I FSOURCE="" Q ""
  1. ;
  1. S FIEN=$$PP^BQIDCDF(FSOURCE) ; Filter ien
  1. I FIEN=-1 S BMXSEC="Filter SOURCE was not found" Q ""
  1. ;
  1. ;Get each filter from panel definition
  1. S FN=0 F S FN=$O(^BQICARE(OWNR,1,PLIEN,15,FN)) Q:'FN D
  1. . NEW DA,IENS,FNAME,VALUE,PEXE,PTYP,PORD,VALUE,ASTR,PMAP,OFNAME
  1. . S DA(2)=OWNR,DA(1)=PLIEN,DA=FN,IENS=$$IENS^DILF(.DA)
  1. . S (OFNAME,FNAME)=$$GET1^DIQ(90505.115,IENS,.01,"E") Q:FNAME=""
  1. . S PTYP=$$PTYP^BQIDCDF(FSOURCE,FNAME) Q:PTYP=""
  1. . S PORD=$$PORD^BQIDCDF(FSOURCE,FNAME) Q:PORD=""
  1. . S VALUE=$$GVAL(PTYP,90505.115,IENS,FSOURCE,FNAME)
  1. . ;
  1. . ;Pull associate parameters
  1. . S ASTR=$$ASPARM^BQIPDSCL(FN)
  1. . ;
  1. . ;Call any defined executable
  1. . S PMAP=$$PMAP^BQIDCDF(FSOURCE,FNAME) I VALUE]"",PMAP]"" D MAP^BQIPDSCM(FSOURCE,PMAP,.VALUE,.FNAME)
  1. . S PEXE=$$PEXE^BQIDCDF(FSOURCE,FNAME) I VALUE]"",PEXE]"" X PEXE
  1. . ;
  1. . ;Save single value
  1. . I VALUE]"" D Q
  1. .. I $G(ASTR)="",FNAME="LAB",$G(VALUE)'="",VALUE["^" S VALUE=$P(VALUE,"^",1)
  1. .. I $G(ASTR)="",FNAME="MEAS",$G(VALUE)'="",VALUE["^" S VALUE=$P(VALUE,"^",1)
  1. .. I $G(ASTR)'="" D
  1. ... NEW RES
  1. ... I ASTR["NUMLAB" D
  1. .... S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1)
  1. .... S VALUE=VALUE_" is"_$$LBRS^BQIPDSC1(ASTR)
  1. ... NEW RES
  1. ... I ASTR["NUMMEAS" D
  1. .... S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1)
  1. .... S VALUE=VALUE_" is"_$$MSRS^BQIPDSC2(ASTR)
  1. ... I ASTR["SETLAB" D
  1. .... S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1),ASTR=$P(ASTR,"SETLAB",2)
  1. .... NEW LVAL,NVAL
  1. .... S VALUE=VALUE_" is "
  1. .... S ASTR=$TR(ASTR,$C(28),""),NVAL=$L(ASTR,$C(29))
  1. .... 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:"")
  1. ... S VALUE=$$TKO^BQIUL1(VALUE," or ")
  1. ... I ASTR["SETMEAS" D
  1. .... ;S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1),ASTR=$P(ASTR,"SETMEAS",2)
  1. .... S ASTR=$P(ASTR,"SETMEAS",2)
  1. .... NEW LVAL,NVAL,AN
  1. .... S AN=$O(^BQI(90507.2,"B",VALUE,"")) I AN'="" S RES=$G(^BQI(90507.2,AN,2))
  1. .... I AN="" S AN=$O(^BQI(90507.2,"C",VALUE,"")) I AN'="" S RES=$G(^BQI(90507.2,AN,2))
  1. .... S VALUE=VALUE_" is "
  1. .... S ASTR=$TR(ASTR,$C(28),""),NVAL=$L(ASTR,$C(29))
  1. .... 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:"")
  1. ... S VALUE=$$TKO^BQIUL1(VALUE," or ")
  1. .. S FPARMS(PORD,FNAME,$$TRUNC^BQIPDSCM(VALUE))=""
  1. . ;
  1. . ;Save multiple values
  1. . S MN=0 F S MN=$O(^BQICARE(OWNR,1,PLIEN,15,FN,1,MN)) Q:'MN D
  1. .. NEW DA,IENS,VALUE
  1. .. S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=FN,DA=MN,IENS=$$IENS^DILF(.DA)
  1. .. S FNAME=OFNAME
  1. .. S VALUE=$$GMVAL(PTYP,90505.1151,IENS,FSOURCE,FNAME)
  1. .. ;
  1. .. ;Pull associate parameters
  1. .. S ASTR=$$ASMPARM^BQIPDSCL(MN)
  1. .. ;
  1. .. ;Call any defined executable
  1. .. I VALUE]"",PMAP]"" D MAP^BQIPDSCM(FSOURCE,PMAP,.VALUE,.FNAME)
  1. .. I VALUE]"",PEXE]"" X PEXE
  1. .. ;
  1. .. ;Save multiple value
  1. .. I VALUE]"" D
  1. ... I $G(ASTR)="",FNAME="LAB",$G(VALUE)'="",VALUE["^" S VALUE=$P(VALUE,"^",1)
  1. ... I $G(ASTR)="",FNAME="MEAS",$G(VALUE)'="",VALUE["^" S VALUE=$P(VALUE,"^",1)
  1. ... I $G(ASTR)'="" D
  1. .... NEW RES
  1. .... I ASTR["NUMLAB" D
  1. ..... S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1)
  1. ..... S VALUE=VALUE_" is"_$$LBRS^BQIPDSC1(ASTR)
  1. .... NEW RES
  1. .... I ASTR["NUMMEAS" D
  1. ..... S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1)
  1. ..... S VALUE=VALUE_" is"_$$MSRS^BQIPDSC2(ASTR)
  1. .... I ASTR["SETLAB" D
  1. ..... S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1),ASTR=$P(ASTR,"SETLAB",2)
  1. ..... S VALUE=VALUE_" is "
  1. ..... NEW LVAL,NVAL
  1. ..... S ASTR=$TR(ASTR,$C(28),""),NVAL=$L(ASTR,$C(29))
  1. ..... 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:"")
  1. .... ;S VALUE=$$TKO^BQIUL1(VALUE," or ")
  1. .... I ASTR["SETMEAS" D
  1. ..... ;S RES=$P(VALUE,U,2),VALUE=$P(VALUE,U,1),ASTR=$P(ASTR,"SETMEAS",2)
  1. ..... S ASTR=$P(ASTR,"SETMEAS",2)
  1. ..... NEW LVAL,NVAL,AN
  1. ..... S AN=$O(^BQI(90507.2,"B",VALUE,"")) I AN'="" S RES=$G(^BQI(90507.2,AN,2))
  1. ..... I AN="" S AN=$O(^BQI(90507.2,"C",VALUE,"")) I AN'="" S RES=$G(^BQI(90507.2,AN,2))
  1. ..... S VALUE=VALUE_" is "
  1. ..... S ASTR=$TR(ASTR,$C(28),""),NVAL=$L(ASTR,$C(29))
  1. ..... 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:"")
  1. .... S VALUE=$$TKO^BQIUL1(VALUE," or ")
  1. ... S FPARMS(PORD,FNAME,$$TRUNC^BQIPDSCM(VALUE))=""
  1. Q
  1. ;
  1. GVAL(PTYP,FILN,IENS,SRC,NM) ; EP - Get value of parameter/filter
  1. N VALUE,BQFIL,PEXE,LABR
  1. ;
  1. ;Table
  1. I PTYP="T" D
  1. . S VALUE=$$GET1^DIQ(FILN,IENS,.03,"E")
  1. . I VALUE[";" D Q
  1. .. NEW PGL
  1. .. S PGL="^"_$P(VALUE,";",2),PGL=$$TKO^BQIUL1(PGL,"(")
  1. .. S VALUE=$P(@PGL@($P(VALUE,";",1),0),U,1)
  1. . S BQFIL=$$FILN^BQIDCDF(SRC,NM) Q:BQFIL=""
  1. . I NM="LAB",VALUE'="" S LABR=$$LSET^BQIDCAH3(VALUE)
  1. . I NM="MEAS",VALUE'="" S VALUE=$$GET1^DIQ(BQFIL,VALUE_",",.01,"E") Q
  1. . S VALUE=$$GET1^DIQ(BQFIL,VALUE_",",.01,"E")
  1. ;
  1. ;Non-table
  1. I PTYP'="T" S VALUE=$$GET1^DIQ(FILN,IENS,.02,"E")
  1. I PTYP="D" S VALUE=$$UP^XLFSTR($$FMTE^XLFDT(VALUE,1))
  1. I PTYP="R" D
  1. . ;No longer needs converted
  1. . ;S VALUE=$$DATE^BQIUL1(VALUE)
  1. . ;S VALUE=$$UP^XLFSTR($$FMTE^XLFDT(VALUE,1))
  1. ;
  1. Q VALUE_$S($G(LABR)'="":"^"_LABR,1:"")
  1. ;
  1. GMVAL(PTYP,FILN,IENS,SRC,NM) ; EP - Get value for multiples
  1. N VALUE,BQFIL,LABR
  1. I PTYP="T" D
  1. . S VALUE=$$GET1^DIQ(FILN,IENS,.02,"E")
  1. . S BQFIL=$$FILN^BQIDCDF(SRC,NM) Q:BQFIL=""
  1. . I NM="LAB",VALUE'="" S LABR=$$LSET^BQIDCAH3(VALUE)
  1. . ;I NM="MEAS" Q
  1. . S VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
  1. I PTYP'="T" S VALUE=$$GET1^DIQ(FILN,IENS,.01,"E")
  1. Q VALUE_$S($G(LABR)'="":"^"_LABR,1:"")
  1. ;
  1. DLM(FPARMS,FLD) ;EP - Determine delimiter between multiple entries
  1. NEW PORD,FND,FNAME,FENT
  1. 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
  1. . S FENT="" F S FENT=$O(FPARMS(PORD,FNAME,FENT)) Q:FENT="" D
  1. .. S FPARMS(PORD,FNAME,FENT)=$S($G(VALUE)="&":" AND ",1:" OR ")
  1. Q
  1. ;
  1. AGE ; Format FPARMS("AGE") or FMPARMS("AGE")
  1. NEW AGE,EXT,OP,AGE1,AGE2
  1. I '$D(FPARMS(PORD,"AGE")) D Q
  1. . S AGE=$G(VALUE)
  1. . S EXT=$S($E(AGE)="'":2,1:1),OP=$E(AGE,1,EXT),AGE=$E(AGE,EXT+1,99)
  1. . S AGE=$S(OP="=":AGE,OP=">":"older than "_AGE,OP="<":"younger than "_AGE,OP="'<":AGE_" or older",1:AGE_" or younger")
  1. . I AGE["YRS" S AGE=$P(AGE,"YRS")_" years"_$P(AGE,"YRS",2,99)
  1. . I AGE["MOS" S AGE=$P(AGE,"MOS")_" months"_$P(AGE,"MOS",2,99)
  1. . I AGE["DYS" S AGE=$P(AGE,"DYS")_" days"_$P(AGE,"DYS",2,99)
  1. . S VALUE=AGE
  1. ;
  1. ;Two Age values - must be exclusive or inclusive
  1. S AGE2=$G(VALUE)
  1. S EXT=$S($E(AGE2)="'":2,1:1),OP=$E(AGE2,1,EXT),AGE2=$E(AGE2,EXT+1,99)
  1. I AGE2["YRS" S AGE2=$P(AGE2,"YRS")_" years"_$P(AGE2,"YRS",2,99)
  1. I AGE2["MOS" S AGE2=$P(AGE2,"MOS")_" months"_$P(AGE2,"MOS",2,99)
  1. I AGE2["DYS" S AGE2=$P(AGE2,"DYS")_" days"_$P(AGE2,"DYS",2,99)
  1. ;
  1. ;Inclusive
  1. S AGE1=$O(FPARMS(PORD,"AGE","")) Q:AGE1=""
  1. I AGE1["or older"!(AGE1["or younger") D Q
  1. . K FPARMS(PORD,"AGE",AGE1)
  1. . I AGE1["or older" S AGE1=$P(AGE1," or older")
  1. . E S AGE1=$P(AGE1," or younger")
  1. . S VALUE="between (inclusive) "_AGE1_" and "_AGE2
  1. ;
  1. ;Exclusive
  1. K FPARMS(PORD,"AGE",AGE1)
  1. I AGE1["younger than" S AGE1=$P(AGE1,"younger than ",2)
  1. E S AGE1=$P(AGE1,"older than ",2)
  1. S VALUE="younger than "_AGE1_" or older than "_AGE2
  1. Q
  1. ;
  1. DXCAT ;EP - Diagnosis Category
  1. NEW I,STR,DXSTAT
  1. S ASTR=$G(ASTR,"")
  1. F I=1:1:$L(ASTR,$C(26)) D
  1. . NEW AINFO,ANAME,AVAL,NVAL,VAL,PC
  1. . S AINFO=$P(ASTR,$C(26),I)
  1. . S ANAME=$P(AINFO,$C(28)) Q:ANAME=""
  1. . S AVAL=$P(AINFO,$C(28),2) Q:AVAL=""
  1. . S NVAL=""
  1. . F PC=1:1:$L(AVAL,$C(29)) D
  1. .. S VAL=$P(AVAL,$C(29),PC) Q:VAL=""
  1. .. S VAL=$S(VAL="A":"Accepted",VAL="P":"Proposed",VAL="N":"Not Accepted",VAL="V":"No Longer Valid",VAL="S":"Superseded",1:"")
  1. .. S:VAL]"" NVAL=NVAL_$S(NVAL]"":", ",1:"")_VAL
  1. . I ANAME]"",NVAL]"" S @ANAME=NVAL
  1. ;
  1. S STR="Diagnostic Tag "_VALUE
  1. S:$G(DXSTAT)]"" STR=STR_" (Diagnostic Tag Status "_DXSTAT_")"
  1. S VALUE=STR
  1. Q
  1. ;
  1. DEC ;EP - Format Patient status
  1. ;Save everything under deceased
  1. S PORD=$$PORD^BQIDCDF(FSOURCE,"DEC") Q:PORD=""
  1. ;Deceased
  1. I FNAME="DEC" D
  1. . NEW PORD,DECDT,DECFDT,DECTDT
  1. . S VALUE=$S($G(VALUE)="Y":"Deceased",1:"")
  1. . Q:VALUE=""
  1. . ;Tack on Deceased information
  1. . ;Deceased from date
  1. . S DECFDT=$$GETVAL(OWNR,PLIEN,"DECFDT")
  1. . I DECFDT]"" S VALUE=VALUE_" (Range from date "_$$FMTE^BQIUL1(DECFDT)
  1. . ;Deceased thru date
  1. . S DECTDT=$$GETVAL(OWNR,PLIEN,"DECTDT")
  1. . I DECTDT]"" S VALUE=VALUE_$S(VALUE["Range":" thru date ",1:" (Range thru date ")_$$FMTE^BQIUL1(DECTDT)
  1. . I VALUE["(" S VALUE=VALUE_")"
  1. ;
  1. ;Living
  1. I FNAME="LIV" S VALUE=$S($G(VALUE)="Y":"Living",1:"") S:VALUE]"" FNAME="DEC"
  1. ;
  1. ;Inactive
  1. I FNAME="INAC" S VALUE=$S($G(VALUE)="Y":"Inactive",1:"") S:VALUE]"" FNAME="DEC"
  1. ;
  1. ;DEMO
  1. I FNAME="DEMO" S VALUE=$S($G(VALUE)="E":"Exclude",$G(VALUE)="O":"Only",1:"Include")_" DEMO " S:VALUE]"" FNAME="DEC"
  1. Q
  1. ;
  1. PLIDEN ; Format FPARMS("PLIDEN") or FMPARMS("PLIDEN")
  1. Q:$G(VALUE)=""
  1. ;
  1. NEW PLOWNR,PLNAME
  1. S PLOWNR=$P(VALUE,$C(26)) S:PLOWNR]"" PLOWNR=$$GET1^DIQ(200,PLOWNR_",",.01,"E")
  1. S:PLOWNR]"" PLOWNR="(Owner: "_PLOWNR_")"
  1. S PLNAME=$P(VALUE,$C(26),2)
  1. ;
  1. S VALUE=PLNAME_$S(PLNAME]"":" ",1:"")_PLOWNR
  1. Q
  1. I $D(FPARMS("PLIDEN")) D
  1. . S PLOWNR=$P(FPARMS("PLIDEN"),$C(26),1),PLOWNR=$$GET1^DIQ(200,PLOWNR_",",.01,"E")
  1. . S FPARMS("PLIDEN")=$P(FPARMS("PLIDEN"),$C(26),2)_" "_PLOWNR
  1. I $D(FMPARMS("PLIDEN")) D
  1. . N PLIEN,PLARR
  1. . S PLIEN=""
  1. . F S PLIEN=$O(FMPARMS("PLIDEN",PLIEN)) Q:PLIEN="" D
  1. .. S PLOWNR=$P(PLIEN,$C(26),1),PLOWNR=$$GET1^DIQ(200,PLOWNR_",",.01,"E")
  1. .. S PLARR($P(PLIEN,$C(26),2)_" "_PLOWNR)=""
  1. . K FMPARMS("PLIDEN")
  1. . M FMPARMS("PLIDEN")=PLARR
  1. Q
  1. ;
  1. LABTX(VALUE) ;EP - Assemble LABTX value
  1. NEW X,DIC,Y,IEN,VAL,LABTST,LTST
  1. I VALUE="" Q
  1. S X=VALUE,DIC="^ATXLAB(" D ^DIC
  1. S VALUE="Lab Taxonomy "_VALUE
  1. I Y="-1" Q
  1. S IEN=+Y_",",VAL=""
  1. D GETS^DIQ(9002228,IEN,"2101*","E","LABTST")
  1. S LTST="" F S LTST=$O(LABTST(9002228.02101,LTST)) Q:LTST="" D
  1. . S VAL=VAL_$S(VAL="":" (Lab Tests ",1:", ")_$G(LABTST(9002228.02101,LTST,".01","E"))
  1. S:VAL["(" VAL=VAL_")"
  1. S VALUE=VALUE_VAL
  1. Q
  1. ;
  1. MEDTX(VALUE) ;EP - Assemble MEDTX value
  1. NEW X,DIC,Y,IEN,VAL,MED,MTST,MD,FILE
  1. I VALUE="" Q
  1. S X=VALUE,DIC="^ATXAX(" D ^DIC
  1. S VALUE="Medication Taxonomy "_VALUE
  1. I Y="-1" Q
  1. S IEN=+Y_",",VAL=""
  1. D GETS^DIQ(9002226,IEN,".15;2101*","IE","MED")
  1. S FILE=$G(MED(9002226,IEN,.15,"I")) Q:FILE=""
  1. S MTST="" F S MTST=$O(MED(9002226.02101,MTST)) Q:MTST="" D
  1. . S MD=$G(MED(9002226.02101,MTST,".01","E")) Q:MD=""
  1. . S MD=$$GET1^DIQ(FILE,MD_",",.01,"E")
  1. . S VAL=VAL_$S(VAL="":" (Medications ",1:", ")_MD
  1. S:VAL["(" VAL=VAL_")"
  1. S VALUE=VALUE_VAL
  1. Q
  1. ;
  1. PRBTX(VALUE) ;EP - Assemble PROBTX value
  1. NEW X,DIC,Y,IEN,VAL,PROB,PTST,PB,FILE
  1. I VALUE="" Q
  1. S X=VALUE,DIC="^ATXAX(" D ^DIC
  1. S VALUE="Problem Taxonomy "_VALUE
  1. I Y="-1" Q
  1. S IEN=+Y_",",VAL=" ("
  1. D GETS^DIQ(9002226,IEN,".15;2101*","IE","PROB")
  1. S FILE=$G(PROB(9002226,IEN,.15,"I")) Q:FILE=""
  1. S PTST="" F S PTST=$O(PROB(9002226.02101,PTST)) Q:PTST="" D
  1. . S PB=$G(PROB(9002226.02101,PTST,".01","E")) Q:PB=""
  1. . S VAL=VAL_$$TKO^BQIUL1(PB," ")_", "
  1. S VAL=$$TKO^BQIUL1(VAL,", ")
  1. S:VAL["(" VAL=VAL_")"
  1. S VALUE=VALUE_VAL
  1. Q
  1. ;
  1. GETVAL(OWNR,PLIEN,FLD) ;EP - Retrieve Single field value
  1. N DECIEN,DA,IEN,IENS
  1. S IEN=$O(^BQICARE(OWNR,1,PLIEN,15,"B",FLD,"")) Q:IEN="" ""
  1. S DA(2)=OWNR,DA(1)=PLIEN,DA=IEN,IENS=$$IENS^DILF(.DA)
  1. Q $$GET1^DIQ(90505.115,IENS,.02,"I")
  1. ;
  1. ICD(ICDIEN) ;EP - Return ICD Information
  1. NEW ICD
  1. S ICD=""
  1. ;Pull appropriate ICD-9/ICD-10 code
  1. ;ICD-9
  1. I $$VERSION^XPDUTL("AICD")<4.0 D
  1. . NEW STR
  1. . I '$L($T(ICDDX^ICDCODE)) D Q
  1. .. S ICD=$$GET1^DIQ(80,ICDIEN_",",.03,"I")_U_$$GET1^DIQ(80,ICDIEN_",",.01,"I")
  1. . S STR=$$ICDDX^ICDCODE(ICDIEN) I $P(STR,U)="-1" Q
  1. . S ICD=$P(STR,U,4)_U_$P(STR,U,2)
  1. ;
  1. ;ICD-9 or ICD-10
  1. I $$VERSION^XPDUTL("AICD")>3.51 D
  1. . ;First try to locate ICD-10
  1. . I $$IMP^ICDEXA(30)'>DT D Q:ICD]""
  1. .. NEW STR
  1. .. S STR=$$ICDDATA^ICDXCODE(30,ICDIEN,DT,"E") I $P(STR,U)="-1" Q
  1. .. S ICD=$P(STR,U,4)_U_$P(STR,U,2)
  1. . ;If not an ICD-10 code try ICD-9 (could be before date or a historical entry)
  1. . I $G(ICD)="" D
  1. .. NEW STR
  1. .. S STR=$$ICDDATA^ICDXCODE(1,ICDIEN,DT,"E") I $P(STR,U)="-1" Q
  1. .. S ICD=$P(STR,U,4)_U_$P(STR,U,2)
  1. Q $S(ICD]"":($P(ICD,U)_" ("_$P(ICD,U,2)_")"),1:"")
  1. ;
  1. PRST(VALUE) ;EP - Problem statuses
  1. NEW FILE,FLD
  1. S FILE=9000011,FLD=.12
  1. S VALUE=$$STC^BQIUL2(FILE,FLD,VALUE)
  1. Q