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
