BDMUTL.m

BDMUTL ; IHS/CMI/LAB - Area Database Utility Routine ; 14 Sep 2015  12:41 PM

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**5,8,9,10,11,12**;JUN 14, 2007;Build 51

 ;

SNOMED(YR,LIST,SMC) ;EP - is snomed code smc on the list for the year

 I 'YR S YR=2019

 I LIST="" Q ""

 I SMC="" Q ""

 NEW YRI,LISTI

 S YRI=$O(^BDMSNME("B",YR,0)) I 'YRI Q ""

 S LISTI=$O(^BDMSNME(YRI,11,"B",LIST,0)) I 'LISTI Q ""

 I $D(^BDMSNME(YRI,11,LISTI,11,"B",SMC)) Q 1

 Q ""

GETIMMS(P,EDATE,C,BDMX) ;EP

 K BDMX

 NEW X,Y,I,Z,V

 S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D

 .Q:'$D(^AUPNVIMM(X,0))  ;happens

 .S Y=$P(^AUPNVIMM(X,0),U)

 .Q:'Y  ;happens too

 .S I=$P($G(^AUTTIMM(Y,0)),U,3)  ;get HL7/CVX code

 .F Z=1:1:$L(C,U) I I=$P(C,U,Z) S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".") I D]"",D'>EDATE S BDMX(D)=Y

 .Q

 Q

IMMREF(P,IMM,BD,ED) ;EP

 NEW X,Y,G,D,R

 I 'IMM Q ""

 S (X,G)=0,Y=$O(^AUTTIMM("C",IMM,0))

 I 'Y Q ""

 F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .Q:$P(^BICONT(R,0),U,1)'["Refusal"

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .Q:$P(^BIPC(X,0),U,4)<BD

 .Q:$P(^BIPC(X,0),U,4)>ED

 .S G=G+1

 Q G

ANCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRAINDICATION

 NEW X

 S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .;Q:$P(^BIPC(X,0),U,4)<BD

 .Q:$P(^BIPC(X,0),U,4)>ED

 .I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G="2  No - Contraindication Anaphylaxis"

 Q G

DEMO(P,T) ;EP - called to exclude demo patients

 I $G(P)="" Q 0

 I $G(T)="" S T="I"

 I T="I" Q 0

 NEW R

 S R=""

 I T="E" D  Q R

 .I $P($G(^DPT(P,0)),U)["DEMO,PATIENT" S R=1 Q

 .NEW %

 .S %=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0))

 .I '% S R=0 Q

 .I $D(^DIBT(%,1,P)) S R=1 Q

 I T="O" D  Q R

 .I $P($G(^DPT(P,0)),U)["DEMO,PATIENT" S R=0 Q

 .NEW %

 .S %=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0))

 .I '% S R=1 Q

 .I $D(^DIBT(%,1,P)) S R=0 Q

 .S R=1 Q

 Q 0

 ;

RZERO(V,L) ;ep right zero fill 

 NEW %,I

 S %=$L(V),Z=L-% F I=1:1:Z S V=V_"0"

 Q V

LZERO(V,L) ;EP - left zero fill

 NEW %,I

 S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V

 Q V

LBLK(V,L) ;EP -left blank fill

 NEW %,I

 S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V

 Q V

RBLK(V,L) ;EP right blank fill

 NEW %,I

 S %=$L(V),Z=L-% F I=1:1:Z S V=V_" "

 Q V

 ;

DEMOCHK(R) ;EP - check demo pat

 NEW DIR,DA

 S R=-1

 S DIR(0)="S^I:Include ALL Patients;E:Exclude DEMO Patients;O:Include ONLY DEMO Patients",DIR("A")="Demo Patient Inclusion/Exclusion",DIR("B")="E"

 KILL DA D ^DIR KILL DIR

 I $D(DIRUT) S R=-1 Q

 S R=Y

 Q

 ;

ICD(VAL,TAXNM,TYP) ;EP -- check to see if value is in taxonomy in ^TMP("BDMTMP",$J,Taxonomy Name

 ;add 3rd param with pass type

 I $G(VAL)="" Q 0

 I $G(TAXNM)="" Q 0

 I $G(TYP)="" Q 0

 I $G(BDMJOB)=""!($G(BDMBTH)="") Q $$ICD^ATXCHK(VAL,$O(^ATXAX("B",TAXNM,0)),TYP)

 I '$D(^XTMP("BDMTAX",BDMJOB,BDMBTH,TAXNM)) Q $$ICD^ATXCHK(VAL,$O(^ATXAX("B",TAXNM,0)),TYP)

 I $D(^XTMP("BDMTAX",BDMJOB,BDMBTH,TAXNM,VAL)) Q 1

 Q 0

 ;

UNFOLDTX(YEAR) ;EP -- unfold all taxes for dm audit into ^TMP("BDMTMP",$J,Taxonomy Name

 ;lets go through all the taxonomies needed here and put them in above location

 ;need to check DMS Taxonomies Used option to determine

 K ^XTMP("BDMTAX",BDMJOB,BDMBTH)

 I '$D(^ICDS(0)) Q  ;only in icd10 environment

 N BDMYR,BDMDA,BDMTAX,BDMFL,BDMTAXI,BDMVAL,BDMTYP,BDMTGT

 S BDMYR=$O(^BDMTAXS("B",YEAR,0))

 Q:'BDMYR

 S BDMDA=0 F  S BDMDA=$O(^BDMTAXS(BDMYR,11,BDMDA)) Q:'BDMDA  D

 . S BDMTAX=$P($G(^BDMTAXS(BDMYR,11,BDMDA,0)),U)

 . S BDMFL=$P($G(^BDMTAXS(BDMYR,11,BDMDA,0)),U,2)

 . S BDMTYP=$S(BDMFL=60:"L",1:"")

 . S BDMTAXI=$O(^ATXAX("B",BDMTAX,0))

 . I BDMTYP="L" D

 .. S BDMTAXI=$O(^ATXLAB("B",BDMTAX,0))

 . S BDMTGT="^XTMP("_"""BDMTAX"""_","_BDMJOB_","_""""_BDMBTH_""""_","_""""_BDMTAX_""""_")"

 . ;D BLDTAX^ATXAPI(BDMTAX,BDMTGT,BDMTAXI,BDMTYP)

 . D BLDTAX^BDMTAPI(BDMTAX,BDMTGT,BDMTAXI,BDMTYP)

 Q

BUILDSML(Y) ;EP - BUILD SNOMED LISTS FROM SUBSETS

 NEW BDMDA,N,OUT,X,BDMY,C,S

 I $T(SUBLST^BSTSAPI)="" Q  ;NO SNOMED STUFF INSTALLED

 S BDMY=$O(^BDMSNME("B",Y,0))

 S BDMDA=0 F  S BDMDA=$O(^BDMSNME(BDMY,11,BDMDA)) Q:BDMDA'=+BDMDA  D

 .Q:'$P(^BDMSNME(BDMY,11,BDMDA,0),U,2)

 .S N=$P(^BDMSNME(BDMY,11,BDMDA,0),U,1)  ;subset name

 .K ^TMP($J,"SUB")

 .S OUT=$NA(^TMP($J,"SUB"))

 .S X=$$SUBLST^BSTSAPI(OUT,N)  ;

 .I '$O(^TMP($J,"SUB",0)) Q  ;NO CODES??

 .;BUILD INDEX

 .S S=0

 .K ^BDMSNME(BDMY,11,BDMDA,11)

 .S C=0 F  S C=$O(^TMP($J,"SUB",C)) Q:C'=+C  S I=$P(^TMP($J,"SUB",C),U,1) I I]"" S ^BDMSNME(BDMY,11,BDMDA,11,C,0)=I,S=S+1

 .S ^BDMSNME(BDMY,11,BDMDA,11,0)="^9003202.60111101^"_S_U_S

 .K ^TMP($J,"SUB")

 .S DIK="^BDMSNME(" D IXALL^DIK

 .Q

 Q

 ;

ICDDX(C,D,S,I) ;PEP - CHECK FOR ICD10

 I $T(ICDDX^ICDEX)]"" Q $$ICDDX^ICDEX(C,$G(D),,$G(I))

 Q $$ICDDX^ICDCODE(C,$G(D),$G(I))

 ;

ICDOP(C,D,S,I) ;PEP - CHECK FOR ICD10

 I $T(ICDOP^ICDEX)]"" Q $$ICDOP^ICDEX(C,$G(D),,$G(I))

 Q $$ICDOP^ICDCODE(C,$G(D),$G(I))

 ;

VSTD(C,D) ;EP - CHECK FOR ICD10

 I $T(VSTD^ICDEX)]"" Q $$VSTD^ICDEX(C,$G(D))

 Q $$VSTD^ICDCODE(C,$G(D))

 ;

VSTP(C,D) ;EP - CHECK FOR ICD10

 I $T(VSTP^ICDEX)]"" Q $$VSTP^ICDEX(C,$G(D))

 Q $$VSTP^ICDCODE(C,$G(D))

 ;

ICDD(C,A,D) ;EP - CHECK FOR ICD10

 I $T(ICDD^ICDEX)]"" Q $$ICDD^ICDEX(C,A,$G(D))

 Q $$ICDD^ICDCODE(C,A,$G(D))

CODEN(C,F) ;EP CHECK/GET CODE

 I $T(CODEN^ICDEX)]"" Q $$CODEN^ICDEX(C,F)

 Q $$CODEN^ICDCODE(C,F)

PLCL(P,BDMY,A,ED,S,BD) ;EP - is DX on problem list 1 or 0

 I $G(P)="" Q ""

 I $G(A)="" Q ""

 I $G(S)="" S S=0

 I $G(ED)="" S ED=DT

 I $G(BD)="" S BD=$$DOB^AUPNPAT(P)

 S BDMY=$O(^BDMSNME("B",BDMY,0))

 N T,N S T=$O(^BDMSNME(BDMY,11,"B",A,0))

 I 'T Q ""

 N X,Y,I,A,D,G S (X,Y)=0,I="" F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I)  I $D(^AUPNPROB(X,0)) D

 .Q:$P(^AUPNPROB(X,0),U,12)="D"

 .I S Q:$P(^AUPNPROB(X,0),U,12)="I"

 .S A=0,D="",G="" F  S A=$O(^AUPNPROB(X,14,A)) Q:A'=+A!(G)  D

 ..S D=$$VD^APCLV($P(^AUPNPROB(X,14,A,0),U,1))

 ..I D'>ED,D'<BD S G=1  ;GOOD DATE

 .I 'G S A=0,D="" F  S A=$O(^AUPNPROB(X,15,A)) Q:A'=+A!(G)  D

 ..S D=$$VD^APCLV($P(^AUPNPROB(X,15,A,0),U,1))

 ..I D'>ED,D'<BD S G=1

 .I 'G I $P(^AUPNPROB(X,0),U,8)>ED!($P(^AUPNPROB(X,0),U,8)<BD) Q

 .S N=$$VAL^XBDIQ1(9000011,X,80001) I N]"",$D(^BDMSNME(BDMY,11,T,11,"B",N)) S I=1_U_N_U_$P(^AUPNPROB(X,0),U,3)

 Q I

PLTAXND(P,A,E)  ;EP - is dx on problem list as NOT DELETED

  ;P is dfn

  ;a is taxonomy name

  I $G(P)="" Q ""

  I $G(A)="" Q ""

  S E=$G(E)

  NEW T S T=$O(^ATXAX("B",A,0))

  I 'T Q ""  ;bad taxonomy??

  NEW X,Y,I,D

  S (X,Y,I)=0

  F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I)  D

  .Q:'$D(^AUPNPROB(X,0))

  .Q:$P(^AUPNPROB(X,0),U,12)="D"

  .S Y=$P(^AUPNPROB(X,0),U)

  .I E,$P(^AUPNPROB(X,0),U,13)>E Q  ;if there is a doo and it is after report period skip

  .I E,$P(^AUPNPROB(X,0),U,8)>E Q  ;entered after report period, skip

  .Q:'$$ICD^BGP8UTL2(Y,T,9)

  .S D=$P(^AUPNPROB(X,0),U,13)

  .I 'D S D=$P(^AUPNPROB(X,0),U,3)

  .S I=1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)_U_D

  .Q

  Q I

PLTAXID(P,A,B,E)  ;EP - is dx on problem list as either active or inactive?

 ;P is dfn

 ;a is taxonomy name

 I $G(P)="" Q ""

 I $G(A)="" Q ""

 S E=$G(E)

 S B=$G(B)

 NEW T S T=$O(^ATXAX("B",A,0))

 I 'T Q ""  ;bad taxonomy??

 NEW X,Y,I,D,M,O

 S (X,Y,I)=0

 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I)  D

 .Q:'$D(^AUPNPROB(X,0))

 .Q:$P(^AUPNPROB(X,0),U,12)="D"

 .Q:$P(^AUPNPROB(X,0),U,12)="I"

 .S Y=$P(^AUPNPROB(X,0),U)

 .S O=$P(^AUPNPROB(X,0),U,13)

 .S M=$P(^AUPNPROB(X,0),U,3)

 .S D=$P(^AUPNPROB(X,0),U,8)

 .I D'<B,D'>E G CHK

 .I O,O'<B,O'>E G CHK

 .I M,M'<B,M'>E G CHK

 .Q

CHK .;

 .Q:'$$ICD^BGP8UTL2(Y,T,9)

 .S I=1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)_U_$S(O="":M,1:O)_U_X

 .Q

  Q I

BDMUTL    ; IHS/CMI/LAB - Area Database Utility Routine ; 14 Sep 2015  12:41 PM

 +1       ;;2.0;DIABETES MANAGEMENT SYSTEM;**5,8,9,10,11,12**;JUN 14, 2007;Build 51

 +2       ;

SNOMED(YR,LIST,SMC) ;EP - is snomed code smc on the list for the year

 +1        IF 'YR

               SET YR=2019

 +2        IF LIST=""

               QUIT ""

 +3        IF SMC=""

               QUIT ""

 +4        NEW YRI,LISTI

 +5        SET YRI=$ORDER(^BDMSNME("B",YR,0))

           IF 'YRI

               QUIT ""

 +6        SET LISTI=$ORDER(^BDMSNME(YRI,11,"B",LIST,0))

           IF 'LISTI

               QUIT ""

 +7        IF $DATA(^BDMSNME(YRI,11,LISTI,11,"B",SMC))

               QUIT 1

 +8        QUIT ""

GETIMMS(P,EDATE,C,BDMX) ;EP

 +1        KILL BDMX

 +2        NEW X,Y,I,Z,V

 +3        SET X=0

           FOR 

               SET X=$ORDER(^AUPNVIMM("AC",P,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +4       ;happens

                   IF '$DATA(^AUPNVIMM(X,0))

                       QUIT 

 +5                SET Y=$PIECE(^AUPNVIMM(X,0),U)

 +6       ;happens too

                   IF 'Y

                       QUIT 

 +7       ;get HL7/CVX code

                   SET I=$PIECE($GET(^AUTTIMM(Y,0)),U,3)

 +8                FOR Z=1:1:$LENGTH(C,U)

                       IF I=$PIECE(C,U,Z)

                           SET V=$PIECE(^AUPNVIMM(X,0),U,3)

                           IF V

                               SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")

                               IF D]""

                                   IF D'>EDATE

                                       SET BDMX(D)=Y

 +9                QUIT 

               End DoDot:1

 +10       QUIT 

IMMREF(P,IMM,BD,ED) ;EP

 +1        NEW X,Y,G,D,R

 +2        IF 'IMM

               QUIT ""

 +3        SET (X,G)=0

           SET Y=$ORDER(^AUTTIMM("C",IMM,0))

 +4        IF 'Y

               QUIT ""

 +5        FOR 

               SET X=$ORDER(^BIPC("AC",P,Y,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +6                SET R=$PIECE(^BIPC(X,0),U,3)

 +7                IF R=""

                       QUIT 

 +8                IF '$DATA(^BICONT(R,0))

                       QUIT 

 +9                IF $PIECE(^BICONT(R,0),U,1)'["Refusal"

                       QUIT 

 +10               SET D=$PIECE(^BIPC(X,0),U,4)

 +11               IF D=""

                       QUIT 

 +12               IF $PIECE(^BIPC(X,0),U,4)<BD

                       QUIT 

 +13               IF $PIECE(^BIPC(X,0),U,4)>ED

                       QUIT 

 +14               SET G=G+1

               End DoDot:1

 +15       QUIT G

ANCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRAINDICATION

 +1        NEW X

 +2        SET X=0

           SET G=""

           SET Y=$ORDER(^AUTTIMM("C",C,0))

           IF Y

               FOR 

                   SET X=$ORDER(^BIPC("AC",P,Y,X))

                   IF X'=+X!(G)

                       QUIT 

                   Begin DoDot:1

 +3                    SET R=$PIECE(^BIPC(X,0),U,3)

 +4                    IF R=""

                           QUIT 

 +5                    IF '$DATA(^BICONT(R,0))

                           QUIT 

 +6                    SET D=$PIECE(^BIPC(X,0),U,4)

 +7                    IF D=""

                           QUIT 

 +8       ;Q:$P(^BIPC(X,0),U,4)<BD

 +9                    IF $PIECE(^BIPC(X,0),U,4)>ED

                           QUIT 

 +10                   IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"

                           SET G="2  No - Contraindication Anaphylaxis"

                   End DoDot:1

 +11       QUIT G

DEMO(P,T) ;EP - called to exclude demo patients

 +1        IF $GET(P)=""

               QUIT 0

 +2        IF $GET(T)=""

               SET T="I"

 +3        IF T="I"

               QUIT 0

 +4        NEW R

 +5        SET R=""

 +6        IF T="E"

               Begin DoDot:1

 +7                IF $PIECE($GET(^DPT(P,0)),U)["DEMO,PATIENT"

                       SET R=1

                       QUIT 

 +8                NEW %

 +9                SET %=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))

 +10               IF '%

                       SET R=0

                       QUIT 

 +11               IF $DATA(^DIBT(%,1,P))

                       SET R=1

                       QUIT 

               End DoDot:1

               QUIT R

 +12       IF T="O"

               Begin DoDot:1

 +13               IF $PIECE($GET(^DPT(P,0)),U)["DEMO,PATIENT"

                       SET R=0

                       QUIT 

 +14               NEW %

 +15               SET %=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))

 +16               IF '%

                       SET R=1

                       QUIT 

 +17               IF $DATA(^DIBT(%,1,P))

                       SET R=0

                       QUIT 

 +18               SET R=1

                   QUIT 

               End DoDot:1

               QUIT R

 +19       QUIT 0

 +20      ;

RZERO(V,L) ;ep right zero fill 

 +1        NEW %,I

 +2        SET %=$LENGTH(V)

           SET Z=L-%

           FOR I=1:1:Z

               SET V=V_"0"

 +3        QUIT V

LZERO(V,L) ;EP - left zero fill

 +1        NEW %,I

 +2        SET %=$LENGTH(V)

           SET Z=L-%

           FOR I=1:1:Z

               SET V="0"_V

 +3        QUIT V

LBLK(V,L) ;EP -left blank fill

 +1        NEW %,I

 +2        SET %=$LENGTH(V)

           SET Z=L-%

           FOR I=1:1:Z

               SET V=" "_V

 +3        QUIT V

RBLK(V,L) ;EP right blank fill

 +1        NEW %,I

 +2        SET %=$LENGTH(V)

           SET Z=L-%

           FOR I=1:1:Z

               SET V=V_" "

 +3        QUIT V

 +4       ;

DEMOCHK(R) ;EP - check demo pat

 +1        NEW DIR,DA

 +2        SET R=-1

 +3        SET DIR(0)="S^I:Include ALL Patients;E:Exclude DEMO Patients;O:Include ONLY DEMO Patients"

           SET DIR("A")="Demo Patient Inclusion/Exclusion"

           SET DIR("B")="E"

 +4        KILL DA

           DO ^DIR

           KILL DIR

 +5        IF $DATA(DIRUT)

               SET R=-1

               QUIT 

 +6        SET R=Y

 +7        QUIT 

 +8       ;

ICD(VAL,TAXNM,TYP) ;EP -- check to see if value is in taxonomy in ^TMP("BDMTMP",$J,Taxonomy Name

 +1       ;add 3rd param with pass type

 +2        IF $GET(VAL)=""

               QUIT 0

 +3        IF $GET(TAXNM)=""

               QUIT 0

 +4        IF $GET(TYP)=""

               QUIT 0

 +5        IF $GET(BDMJOB)=""!($GET(BDMBTH)="")

               QUIT $$ICD^ATXCHK(VAL,$ORDER(^ATXAX("B",TAXNM,0)),TYP)

 +6        IF '$DATA(^XTMP("BDMTAX",BDMJOB,BDMBTH,TAXNM))

               QUIT $$ICD^ATXCHK(VAL,$ORDER(^ATXAX("B",TAXNM,0)),TYP)

 +7        IF $DATA(^XTMP("BDMTAX",BDMJOB,BDMBTH,TAXNM,VAL))

               QUIT 1

 +8        QUIT 0

 +9       ;

UNFOLDTX(YEAR) ;EP -- unfold all taxes for dm audit into ^TMP("BDMTMP",$J,Taxonomy Name

 +1       ;lets go through all the taxonomies needed here and put them in above location

 +2       ;need to check DMS Taxonomies Used option to determine

 +3        KILL ^XTMP("BDMTAX",BDMJOB,BDMBTH)

 +4       ;only in icd10 environment

           IF '$DATA(^ICDS(0))

               QUIT 

 +5        NEW BDMYR,BDMDA,BDMTAX,BDMFL,BDMTAXI,BDMVAL,BDMTYP,BDMTGT

 +6        SET BDMYR=$ORDER(^BDMTAXS("B",YEAR,0))

 +7        IF 'BDMYR

               QUIT 

 +8        SET BDMDA=0

           FOR 

               SET BDMDA=$ORDER(^BDMTAXS(BDMYR,11,BDMDA))

               IF 'BDMDA

                   QUIT 

               Begin DoDot:1

 +9                SET BDMTAX=$PIECE($GET(^BDMTAXS(BDMYR,11,BDMDA,0)),U)

 +10               SET BDMFL=$PIECE($GET(^BDMTAXS(BDMYR,11,BDMDA,0)),U,2)

 +11               SET BDMTYP=$SELECT(BDMFL=60:"L",1:"")

 +12               SET BDMTAXI=$ORDER(^ATXAX("B",BDMTAX,0))

 +13               IF BDMTYP="L"

                       Begin DoDot:2

 +14                       SET BDMTAXI=$ORDER(^ATXLAB("B",BDMTAX,0))

                       End DoDot:2

 +15               SET BDMTGT="^XTMP("_"""BDMTAX"""_","_BDMJOB_","_""""_BDMBTH_""""_","_""""_BDMTAX_""""_")"

 +16      ;D BLDTAX^ATXAPI(BDMTAX,BDMTGT,BDMTAXI,BDMTYP)

 +17               DO BLDTAX^BDMTAPI(BDMTAX,BDMTGT,BDMTAXI,BDMTYP)

               End DoDot:1

 +18       QUIT 

BUILDSML(Y) ;EP - BUILD SNOMED LISTS FROM SUBSETS

 +1        NEW BDMDA,N,OUT,X,BDMY,C,S

 +2       ;NO SNOMED STUFF INSTALLED

           IF $TEXT(SUBLST^BSTSAPI)=""

               QUIT 

 +3        SET BDMY=$ORDER(^BDMSNME("B",Y,0))

 +4        SET BDMDA=0

           FOR 

               SET BDMDA=$ORDER(^BDMSNME(BDMY,11,BDMDA))

               IF BDMDA'=+BDMDA

                   QUIT 

               Begin DoDot:1

 +5                IF '$PIECE(^BDMSNME(BDMY,11,BDMDA,0),U,2)

                       QUIT 

 +6       ;subset name

                   SET N=$PIECE(^BDMSNME(BDMY,11,BDMDA,0),U,1)

 +7                KILL ^TMP($JOB,"SUB")

 +8                SET OUT=$NAME(^TMP($JOB,"SUB"))

 +9       ;

                   SET X=$$SUBLST^BSTSAPI(OUT,N)

 +10      ;NO CODES??

                   IF '$ORDER(^TMP($JOB,"SUB",0))

                       QUIT 

 +11      ;BUILD INDEX

 +12               SET S=0

 +13               KILL ^BDMSNME(BDMY,11,BDMDA,11)

 +14               SET C=0

                   FOR 

                       SET C=$ORDER(^TMP($JOB,"SUB",C))

                       IF C'=+C

                           QUIT 

                       SET I=$PIECE(^TMP($JOB,"SUB",C),U,1)

                       IF I]""

                           SET ^BDMSNME(BDMY,11,BDMDA,11,C,0)=I

                           SET S=S+1

 +15               SET ^BDMSNME(BDMY,11,BDMDA,11,0)="^9003202.60111101^"_S_U_S

 +16               KILL ^TMP($JOB,"SUB")

 +17               SET DIK="^BDMSNME("

                   DO IXALL^DIK

 +18               QUIT 

               End DoDot:1

 +19       QUIT 

 +20      ;

ICDDX(C,D,S,I) ;PEP - CHECK FOR ICD10

 +1        IF $TEXT(ICDDX^ICDEX)]""

               QUIT $$ICDDX^ICDEX(C,$GET(D),,$GET(I))

 +2        QUIT $$ICDDX^ICDCODE(C,$GET(D),$GET(I))

 +3       ;

ICDOP(C,D,S,I) ;PEP - CHECK FOR ICD10

 +1        IF $TEXT(ICDOP^ICDEX)]""

               QUIT $$ICDOP^ICDEX(C,$GET(D),,$GET(I))

 +2        QUIT $$ICDOP^ICDCODE(C,$GET(D),$GET(I))

 +3       ;

VSTD(C,D) ;EP - CHECK FOR ICD10

 +1        IF $TEXT(VSTD^ICDEX)]""

               QUIT $$VSTD^ICDEX(C,$GET(D))

 +2        QUIT $$VSTD^ICDCODE(C,$GET(D))

 +3       ;

VSTP(C,D) ;EP - CHECK FOR ICD10

 +1        IF $TEXT(VSTP^ICDEX)]""

               QUIT $$VSTP^ICDEX(C,$GET(D))

 +2        QUIT $$VSTP^ICDCODE(C,$GET(D))

 +3       ;

ICDD(C,A,D) ;EP - CHECK FOR ICD10

 +1        IF $TEXT(ICDD^ICDEX)]""

               QUIT $$ICDD^ICDEX(C,A,$GET(D))

 +2        QUIT $$ICDD^ICDCODE(C,A,$GET(D))

CODEN(C,F) ;EP CHECK/GET CODE

 +1        IF $TEXT(CODEN^ICDEX)]""

               QUIT $$CODEN^ICDEX(C,F)

 +2        QUIT $$CODEN^ICDCODE(C,F)

PLCL(P,BDMY,A,ED,S,BD) ;EP - is DX on problem list 1 or 0

 +1        IF $GET(P)=""

               QUIT ""

 +2        IF $GET(A)=""

               QUIT ""

 +3        IF $GET(S)=""

               SET S=0

 +4        IF $GET(ED)=""

               SET ED=DT

 +5        IF $GET(BD)=""

               SET BD=$$DOB^AUPNPAT(P)

 +6        SET BDMY=$ORDER(^BDMSNME("B",BDMY,0))

 +7        NEW T,N

           SET T=$ORDER(^BDMSNME(BDMY,11,"B",A,0))

 +8        IF 'T

               QUIT ""

 +9        NEW X,Y,I,A,D,G

           SET (X,Y)=0

           SET I=""

           FOR 

               SET X=$ORDER(^AUPNPROB("AC",P,X))

               IF X'=+X!(I)

                   QUIT 

               IF $DATA(^AUPNPROB(X,0))

                   Begin DoDot:1

 +10                   IF $PIECE(^AUPNPROB(X,0),U,12)="D"