PXRMTXIN ;SLC/PKR - Taxonomy inquiry for general use. ;01/29/2015
;;2.0;CLINICAL REMINDERS;**26,47**;Feb 04, 2005;Build 291
;==========================================
BTAXALL ;Taxonomy inquiry, return the formatted text OUTPUT.
N BOP,IEN,NAME,OUTPUT,TYPE
S TYPE=$$GTYPE
S BOP=$$BORP^PXRMUTIL("B")
I BOP="" Q
S NAME=""
F S NAME=$O(^PXD(811.2,"B",NAME)) Q:NAME="" D
. S IEN=$O(^PXD(811.2,"B",NAME,""))
. D TAXINQ(TYPE,IEN,.OUTPUT)
. I BOP="B" D BROWSE^DDBR("OUTPUT","NR","Taxonomy Inquiry")
. I BOP="P" D GPRINT^PXRMUTIL("OUTPUT")
Q
;
;==========================================
BTAXINQ(IEN) ;Display a Taxonomy inquiry, defaults to the Browswer.
N BOP,DIR0,OUTPUT,TITLE,TYPE
I '$D(^PXD(811.2,IEN)) Q
S TYPE=$$GTYPE
S TITLE="Taxonomy Inquiry - "_$S(TYPE="C":"Condensed",TYPE="F":"Full",1:"")
D TAXINQ(TYPE,IEN,.OUTPUT)
S BOP=$$BORP^PXRMUTIL("B")
I BOP="" Q
I BOP="B" D BROWSE^DDBR("OUTPUT","NR",TITLE)
I BOP="P" D GPRINT^PXRMUTIL("OUTPUT")
Q
;
;==========================================
CDETAILC(CODESYS,CODE,UID,NL,OUTPUT) ;Get the condensed details about a code.
N ACTDT,DESC,HIER,INACT,INACTDT,LDESC,LHIER,LTEXT,NOLEX,PDATA,TEXT
S UID=$S(UID=1:"X",1:" ")
D CDETAILS(CODESYS,CODE,.NOLEX,.PDATA)
S ACTDT=1000101
F S ACTDT=$O(PDATA(ACTDT)) Q:ACTDT="" D
. S INACTDT=$P(PDATA(ACTDT),U,1)
. S INACT=$S((ACTDT>DT):"X",(INACTDT=""):" ",(INACTDT'>DT):"X",1:" ")
. S DESC=$S(NOLEX=1:$P(PDATA(ACTDT),U,2),1:PDATA(ACTDT,0))
. S LDESC=$L(DESC)
. I (LDESC>51),(CODESYS'="SCT") S DESC=$E(DESC,1,47)_"..."
. I CODESYS="SCT" D
.. S HIER=$$SCTHIER(CODE,ACTDT),LHIER=$L(HIER)
.. I (LDESC+LHIER)'>50 S DESC=DESC_" "_HIER
.. E S DESC=$E(DESC,1,(46-LHIER))_"... "_HIER
. S TEXT=CODE,LTEXT=$L(TEXT)
. S TEXT=TEXT_$$REPEAT^XLFSTR(" ",(22-LTEXT))_INACT,LTEXT=$L(TEXT)
. S TEXT=TEXT_$$REPEAT^XLFSTR(" ",(27-LTEXT))_UID,LTEXT=$L(TEXT)
. S TEXT=TEXT_$$REPEAT^XLFSTR(" ",(30-LTEXT))_DESC
. S NL=NL+1,OUTPUT(NL)=TEXT
Q
;
;==========================================
CDETAILF(CODESYS,CODE,UID,NL,OUTPUT) ;Get the full details about a code.
N ACTDT,DESC,FMTSTR,INACTDT,IND,NOLEX,NOUT,NP,PDATA,TEXT
S FMTSTR="10L1^10C2^10C4^1C3^35L"
S UID=$S(UID=1:"X",1:" ")
D CDETAILS(CODESYS,CODE,.NOLEX,.PDATA)
S ACTDT=1000101,NP=0
F S ACTDT=$O(PDATA(ACTDT)) Q:ACTDT="" D
. S NP=NP+1
. S INACTDT=$P(PDATA(ACTDT),U,1)
. S DESC=$S(NOLEX=1:$P(PDATA(ACTDT),U,2),1:PDATA(ACTDT,0))
. I CODESYS="SCT" S DESC=DESC_" "_$$SCTHIER(CODE,ACTDT)
. I NP=1 S TEXT=CODE_U_$$FMTE^XLFDT(ACTDT,"5Z")_U_$$FMTE^XLFDT(INACTDT,"5Z")_U_UID_U_DESC
. I NP>1 S TEXT=U_$$FMTE^XLFDT(ACTDT,"5Z")_U_$$FMTE^XLFDT(INACTDT,"5Z")_U_UID_U_DESC
. D COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NOUT,.TEXTOUT)
. F IND=1:1:NOUT S NL=NL+1,OUTPUT(NL)=TEXTOUT(IND)
Q
;
;==========================================
CDETAILS(CODESYS,CODE,NOLEX,PDATA) ;Get the details about a code.
N RESULT
;DBIA #5679
S RESULT=$$PERIOD^LEXU(CODE,CODESYS,.PDATA)
S NOLEX=0
I +RESULT=-1 D
. S NOLEX=1
.;DBIA #1997, #3991
. I (CODESYS="CPC")!(CODESYS="CPT") D PERIOD^ICPTAPIU(CODE,.PDATA)
. I (CODESYS="ICD")!(CODESYS="ICP") D PERIOD^ICDAPIU(CODE,.PDATA)
Q
;
;==========================================
GTYPE() ;Prompt the user for the type of output.
N DIR,POP,X,Y
S DIR(0)="SA"_U_"C:Condensed;F:Full"
S DIR("A")="Condensed or full inquiry? "
S DIR("B")="C"
D ^DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) Q "F"
Q Y
;
;==========================================
SCTHIER(CODE,ACTDT) ;Return the SNOMED hierarchy.
N FSN,HE,HIER,HS
;DBIA #5007
S FSN=$$GETFSN^LEXTRAN1("SCT",CODE,ACTDT)
S HS=$F(FSN,"(")
S HE=$F(FSN,")",HS)
S HIER=$E(FSN,HS-1,HE-1)
Q HIER
;
;==========================================
TAXINQ(TYPE,IEN,OUTPUT) ;Taxonomy inquiry, return the formatted text OUTPUT.
;Use 80 column output.
N CHDR,CODE,CODEP,CODESYS,CODESYSN,DUPL,IND,NL,OCL,IENSTR
N NCODES,NOUT,NPAD,NUCODES,RM,T100,TEMP,TERM,TEXT,TEXTOUT
N UID,WPARRAY
S RM=80
I TYPE="C" D
. S CHDR(1)="Code INACT UID Description"
. S CHDR(2)="------------------ ----- --- -----------"
I TYPE="F" D
. S CHDR(1)="Code Activation Inactivation UID Description"
. S CHDR(2)="--------- ---------- ------------ --- -----------"
S TEMP=^PXD(811.2,IEN,0)
S IENSTR="No. "_IEN
S OUTPUT(1)=$$REPEAT^XLFSTR("-",RM)
S TEXT=$P(TEMP,U,1)
S NPAD=RM-$L(TEXT)-1
S OUTPUT(2)=TEXT_$$RJ^XLFSTR(IENSTR,NPAD," ")
S OUTPUT(3)=$$REPEAT^XLFSTR("-",RM)
S OUTPUT(4)=""
S T100=^PXD(811.2,IEN,100)
S OUTPUT(5)="Class: "_$$GET1^DIQ(811.2,IEN,100)
S OUTPUT(6)="Sponsor: "_$$GET1^DIQ(811.2,IEN,101)
S OUTPUT(7)="Review Date: "_$$GET1^DIQ(811.2,IEN,102)
S OUTPUT(8)=""
S OUTPUT(9)="Description:"
S NL=9
S TEMP=$$GET1^DIQ(811.2,IEN,2,"","WPARRAY")
I TEMP="" S NL=NL+1,OUTPUT(NL)=""
I TEMP="WPARRAY" D
. S IND=0
. F S IND=$O(WPARRAY(IND)) Q:IND="" S NL=NL+1,OUTPUT(NL)=WPARRAY(IND)
. K WPARRAY
. S NL=NL+1,OUTPUT(NL)=""
S TEMP=$G(^PXD(811.2,IEN,40))
S NL=NL+1,OUTPUT(NL)="Inactive Flag: "_$$GET1^DIQ(811.2,IEN,1.6)
S NL=NL+1,OUTPUT(NL)="Patient Data Source: "_$$GET1^DIQ(811.2,IEN,4)
S NL=NL+1,OUTPUT(NL)="Use Inactive Problems: "_$$GET1^DIQ(811.2,IEN,10)
;Initialze the code counter.
K ^TMP($J,"CC")
S CODESYS=""
F S CODESYS=$O(^PXD(811.2,IEN,20,"AE",CODESYS)) Q:CODESYS="" D
. S (NCODES(CODESYS),NUCODES(CODESYS))=0
.;DBIA #5679
. I '$D(CODESYSN(CODESYS)) S CODESYSN(CODESYS)=$P($$CSYS^LEXU(CODESYS),U,4)
;Display the selected codes.
S NL=NL+1,OUTPUT(NL)=""
S NL=NL+1,OUTPUT(NL)="Selected Codes:"
S TERM=""
F S TERM=$O(^PXD(811.2,IEN,20,"B",TERM)) Q:TERM="" D
. S NL=NL+1,OUTPUT(NL)=""
. S TEXT="Lexicon Search Term/Code: "_TERM
. D COLFMT^PXRMTEXT(RM_"L",TEXT," ",.NOUT,.TEXTOUT)
. F IND=1:1:NOUT S NL=NL+1,OUTPUT(NL)=TEXTOUT(IND)
. S CODESYS=""
. F S CODESYS=$O(^PXD(811.2,IEN,20,"ATCC",TERM,CODESYS)) Q:CODESYS="" D
.. S NL=NL+1,OUTPUT(NL)=""
..;DBIA #5679
.. S NL=NL+1,OUTPUT(NL)="Coding System: "_CODESYSN(CODESYS)
.. K OCL
.. S CODE=""
.. F S CODE=$O(^PXD(811.2,IEN,20,"ATCC",TERM,CODESYS,CODE)) Q:CODE="" D
... S OCL(CODE_" ")=CODE_U_^PXD(811.2,IEN,20,"ATCC",TERM,CODESYS,CODE)
... S NCODES(CODESYS)=NCODES(CODESYS)+1
... S ^TMP($J,"CC",CODE)=$G(^TMP($J,"CC",CODE))+1
... S ^TMP($J,"CC",CODE,CODESYS,TERM)=""
.. S CODEP=""
.. S NL=NL+1,OUTPUT(NL)=CHDR(1)
.. S NL=NL+1,OUTPUT(NL)=CHDR(2)
.. F S CODEP=$O(OCL(CODEP)) Q:CODEP="" D
... S CODE=$P(OCL(CODEP),U,1),UID=$P(OCL(CODEP),U,2)
... I TYPE="C" D CDETAILC(CODESYS,CODE,UID,.NL,.OUTPUT)
... I TYPE="F" D CDETAILF(CODESYS,CODE,UID,.NL,.OUTPUT)
. S NL=NL+1,OUTPUT(NL)=""
;
;Look for duplicated codes if there are any list them.
S CODE=""
F S CODE=$O(^TMP($J,"CC",CODE)) Q:CODE="" D
. I ^TMP($J,"CC",CODE)>1 S DUPL(CODE)=^TMP($J,"CC",CODE)
;
;If there are duplicates count the number of unique codes.
I $D(DUPL) D
. S CODESYS="",NUCODES=0
. F S CODESYS=$O(^PXD(811.2,IEN,20,"AE",CODESYS)) Q:CODESYS="" D
.. S CODE=""
.. F S CODE=$O(^PXD(811.2,IEN,20,"AE",CODESYS,CODE)) Q:CODE="" D
... S NUCODES(CODESYS)=NUCODES(CODESYS)+1,NUCODES=NUCODES+1
;
S NL=NL+1,OUTPUT(NL)=""
S NL=NL+1,OUTPUT(NL)="This taxonomy includes the following numbers of codes:"
S CODESYS="",TEMP=0
F S CODESYS=$O(NCODES(CODESYS)) Q:CODESYS="" D
. S NL=NL+1,OUTPUT(NL)=CODESYSN(CODESYS)_": "_NCODES(CODESYS)
. I $D(DUPL) S OUTPUT(NL)=OUTPUT(NL)_"; "_NUCODES(CODESYS)_" are unique."
. S TEMP=TEMP+NCODES(CODESYS)
S NL=NL+1,OUTPUT(NL)="Total number of codes: "_TEMP
I $D(DUPL) S OUTPUT(NL)=OUTPUT(NL)_"; "_NUCODES_" are unique."
;
;If there are duplicates, list them.
I '$D(DUPL) K ^TMP($J,"CC") Q
S NL=NL+1,OUTPUT(NL)=""
S NL=NL+1,OUTPUT(NL)="The following codes are included in more than one Term/Code."
S CODE=""
F S CODE=$O(DUPL(CODE)) Q:CODE="" D
. S CODESYS=""
. F S CODESYS=$O(^TMP($J,"CC",CODE,CODESYS)) Q:CODESYS="" D
.. S NL=NL+1,OUTPUT(NL)=CODESYSN(CODESYS)_" code "_CODE_" is included "_DUPL(CODE)_" times."
.. S NL=NL+1,OUTPUT(NL)=" Term/Code:"
.. S TERM=""
.. F S TERM=$O(^TMP($J,"CC",CODE,CODESYS,TERM)) Q:TERM="" D
... S NL=NL+1,OUTPUT(NL)=" "_TERM
. S NL=NL+1,OUTPUT(NL)=""
K ^TMP($J,"CC")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMTXIN 8334 printed Dec 13, 2024@01:49:36 Page 2
PXRMTXIN ;SLC/PKR - Taxonomy inquiry for general use. ;01/29/2015
+1 ;;2.0;CLINICAL REMINDERS;**26,47**;Feb 04, 2005;Build 291
+2 ;==========================================
BTAXALL ;Taxonomy inquiry, return the formatted text OUTPUT.
+1 NEW BOP,IEN,NAME,OUTPUT,TYPE
+2 SET TYPE=$$GTYPE
+3 SET BOP=$$BORP^PXRMUTIL("B")
+4 IF BOP=""
QUIT
+5 SET NAME=""
+6 FOR
SET NAME=$ORDER(^PXD(811.2,"B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+7 SET IEN=$ORDER(^PXD(811.2,"B",NAME,""))
+8 DO TAXINQ(TYPE,IEN,.OUTPUT)
+9 IF BOP="B"
DO BROWSE^DDBR("OUTPUT","NR","Taxonomy Inquiry")
+10 IF BOP="P"
DO GPRINT^PXRMUTIL("OUTPUT")
End DoDot:1
+11 QUIT
+12 ;
+13 ;==========================================
BTAXINQ(IEN) ;Display a Taxonomy inquiry, defaults to the Browswer.
+1 NEW BOP,DIR0,OUTPUT,TITLE,TYPE
+2 IF '$DATA(^PXD(811.2,IEN))
QUIT
+3 SET TYPE=$$GTYPE
+4 SET TITLE="Taxonomy Inquiry - "_$SELECT(TYPE="C":"Condensed",TYPE="F":"Full",1:"")
+5 DO TAXINQ(TYPE,IEN,.OUTPUT)
+6 SET BOP=$$BORP^PXRMUTIL("B")
+7 IF BOP=""
QUIT
+8 IF BOP="B"
DO BROWSE^DDBR("OUTPUT","NR",TITLE)
+9 IF BOP="P"
DO GPRINT^PXRMUTIL("OUTPUT")
+10 QUIT
+11 ;
+12 ;==========================================
CDETAILC(CODESYS,CODE,UID,NL,OUTPUT) ;Get the condensed details about a code.
+1 NEW ACTDT,DESC,HIER,INACT,INACTDT,LDESC,LHIER,LTEXT,NOLEX,PDATA,TEXT
+2 SET UID=$SELECT(UID=1:"X",1:" ")
+3 DO CDETAILS(CODESYS,CODE,.NOLEX,.PDATA)
+4 SET ACTDT=1000101
+5 FOR
SET ACTDT=$ORDER(PDATA(ACTDT))
if ACTDT=""
QUIT
Begin DoDot:1
+6 SET INACTDT=$PIECE(PDATA(ACTDT),U,1)
+7 SET INACT=$SELECT((ACTDT>DT):"X",(INACTDT=""):" ",(INACTDT'>DT):"X",1:" ")
+8 SET DESC=$SELECT(NOLEX=1:$PIECE(PDATA(ACTDT),U,2),1:PDATA(ACTDT,0))
+9 SET LDESC=$LENGTH(DESC)
+10 IF (LDESC>51)
IF (CODESYS'="SCT")
SET DESC=$EXTRACT(DESC,1,47)_"..."
+11 IF CODESYS="SCT"
Begin DoDot:2
+12 SET HIER=$$SCTHIER(CODE,ACTDT)
SET LHIER=$LENGTH(HIER)
+13 IF (LDESC+LHIER)'>50
SET DESC=DESC_" "_HIER
+14 IF '$TEST
SET DESC=$EXTRACT(DESC,1,(46-LHIER))_"... "_HIER
End DoDot:2
+15 SET TEXT=CODE
SET LTEXT=$LENGTH(TEXT)
+16 SET TEXT=TEXT_$$REPEAT^XLFSTR(" ",(22-LTEXT))_INACT
SET LTEXT=$LENGTH(TEXT)
+17 SET TEXT=TEXT_$$REPEAT^XLFSTR(" ",(27-LTEXT))_UID
SET LTEXT=$LENGTH(TEXT)
+18 SET TEXT=TEXT_$$REPEAT^XLFSTR(" ",(30-LTEXT))_DESC
+19 SET NL=NL+1
SET OUTPUT(NL)=TEXT
End DoDot:1
+20 QUIT
+21 ;
+22 ;==========================================
CDETAILF(CODESYS,CODE,UID,NL,OUTPUT) ;Get the full details about a code.
+1 NEW ACTDT,DESC,FMTSTR,INACTDT,IND,NOLEX,NOUT,NP,PDATA,TEXT
+2 SET FMTSTR="10L1^10C2^10C4^1C3^35L"
+3 SET UID=$SELECT(UID=1:"X",1:" ")
+4 DO CDETAILS(CODESYS,CODE,.NOLEX,.PDATA)
+5 SET ACTDT=1000101
SET NP=0
+6 FOR
SET ACTDT=$ORDER(PDATA(ACTDT))
if ACTDT=""
QUIT
Begin DoDot:1
+7 SET NP=NP+1
+8 SET INACTDT=$PIECE(PDATA(ACTDT),U,1)
+9 SET DESC=$SELECT(NOLEX=1:$PIECE(PDATA(ACTDT),U,2),1:PDATA(ACTDT,0))
+10 IF CODESYS="SCT"
SET DESC=DESC_" "_$$SCTHIER(CODE,ACTDT)
+11 IF NP=1
SET TEXT=CODE_U_$$FMTE^XLFDT(ACTDT,"5Z")_U_$$FMTE^XLFDT(INACTDT,"5Z")_U_UID_U_DESC
+12 IF NP>1
SET TEXT=U_$$FMTE^XLFDT(ACTDT,"5Z")_U_$$FMTE^XLFDT(INACTDT,"5Z")_U_UID_U_DESC
+13 DO COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NOUT,.TEXTOUT)
+14 FOR IND=1:1:NOUT
SET NL=NL+1
SET OUTPUT(NL)=TEXTOUT(IND)
End DoDot:1
+15 QUIT
+16 ;
+17 ;==========================================
CDETAILS(CODESYS,CODE,NOLEX,PDATA) ;Get the details about a code.
+1 NEW RESULT
+2 ;DBIA #5679
+3 SET RESULT=$$PERIOD^LEXU(CODE,CODESYS,.PDATA)
+4 SET NOLEX=0
+5 IF +RESULT=-1
Begin DoDot:1
+6 SET NOLEX=1
+7 ;DBIA #1997, #3991
+8 IF (CODESYS="CPC")!(CODESYS="CPT")
DO PERIOD^ICPTAPIU(CODE,.PDATA)
+9 IF (CODESYS="ICD")!(CODESYS="ICP")
DO PERIOD^ICDAPIU(CODE,.PDATA)
End DoDot:1
+10 QUIT
+11 ;
+12 ;==========================================
GTYPE() ;Prompt the user for the type of output.
+1 NEW DIR,POP,X,Y
+2 SET DIR(0)="SA"_U_"C:Condensed;F:Full"
+3 SET DIR("A")="Condensed or full inquiry? "
+4 SET DIR("B")="C"
+5 DO ^DIR
+6 IF $DATA(DIROUT)
SET DTOUT=1
+7 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT "F"
+8 QUIT Y
+9 ;
+10 ;==========================================
SCTHIER(CODE,ACTDT) ;Return the SNOMED hierarchy.
+1 NEW FSN,HE,HIER,HS
+2 ;DBIA #5007
+3 SET FSN=$$GETFSN^LEXTRAN1("SCT",CODE,ACTDT)
+4 SET HS=$FIND(FSN,"(")
+5 SET HE=$FIND(FSN,")",HS)
+6 SET HIER=$EXTRACT(FSN,HS-1,HE-1)
+7 QUIT HIER
+8 ;
+9 ;==========================================
TAXINQ(TYPE,IEN,OUTPUT) ;Taxonomy inquiry, return the formatted text OUTPUT.
+1 ;Use 80 column output.
+2 NEW CHDR,CODE,CODEP,CODESYS,CODESYSN,DUPL,IND,NL,OCL,IENSTR
+3 NEW NCODES,NOUT,NPAD,NUCODES,RM,T100,TEMP,TERM,TEXT,TEXTOUT
+4 NEW UID,WPARRAY
+5 SET RM=80
+6 IF TYPE="C"
Begin DoDot:1
+7 SET CHDR(1)="Code INACT UID Description"
+8 SET CHDR(2)="------------------ ----- --- -----------"
End DoDot:1
+9 IF TYPE="F"
Begin DoDot:1
+10 SET CHDR(1)="Code Activation Inactivation UID Description"
+11 SET CHDR(2)="--------- ---------- ------------ --- -----------"
End DoDot:1
+12 SET TEMP=^PXD(811.2,IEN,0)
+13 SET IENSTR="No. "_IEN
+14 SET OUTPUT(1)=$$REPEAT^XLFSTR("-",RM)
+15 SET TEXT=$PIECE(TEMP,U,1)
+16 SET NPAD=RM-$LENGTH(TEXT)-1
+17 SET OUTPUT(2)=TEXT_$$RJ^XLFSTR(IENSTR,NPAD," ")
+18 SET OUTPUT(3)=$$REPEAT^XLFSTR("-",RM)
+19 SET OUTPUT(4)=""
+20 SET T100=^PXD(811.2,IEN,100)
+21 SET OUTPUT(5)="Class: "_$$GET1^DIQ(811.2,IEN,100)
+22 SET OUTPUT(6)="Sponsor: "_$$GET1^DIQ(811.2,IEN,101)
+23 SET OUTPUT(7)="Review Date: "_$$GET1^DIQ(811.2,IEN,102)
+24 SET OUTPUT(8)=""
+25 SET OUTPUT(9)="Description:"
+26 SET NL=9
+27 SET TEMP=$$GET1^DIQ(811.2,IEN,2,"","WPARRAY")
+28 IF TEMP=""
SET NL=NL+1
SET OUTPUT(NL)=""
+29 IF TEMP="WPARRAY"
Begin DoDot:1
+30 SET IND=0
+31 FOR
SET IND=$ORDER(WPARRAY(IND))
if IND=""
QUIT
SET NL=NL+1
SET OUTPUT(NL)=WPARRAY(IND)
+32 KILL WPARRAY
+33 SET NL=NL+1
SET OUTPUT(NL)=""
End DoDot:1
+34 SET TEMP=$GET(^PXD(811.2,IEN,40))
+35 SET NL=NL+1
SET OUTPUT(NL)="Inactive Flag: "_$$GET1^DIQ(811.2,IEN,1.6)
+36 SET NL=NL+1
SET OUTPUT(NL)="Patient Data Source: "_$$GET1^DIQ(811.2,IEN,4)
+37 SET NL=NL+1
SET OUTPUT(NL)="Use Inactive Problems: "_$$GET1^DIQ(811.2,IEN,10)
+38 ;Initialze the code counter.
+39 KILL ^TMP($JOB,"CC")
+40 SET CODESYS=""
+41 FOR
SET CODESYS=$ORDER(^PXD(811.2,IEN,20,"AE",CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+42 SET (NCODES(CODESYS),NUCODES(CODESYS))=0
+43 ;DBIA #5679
+44 IF '$DATA(CODESYSN(CODESYS))
SET CODESYSN(CODESYS)=$PIECE($$CSYS^LEXU(CODESYS),U,4)
End DoDot:1
+45 ;Display the selected codes.
+46 SET NL=NL+1
SET OUTPUT(NL)=""
+47 SET NL=NL+1
SET OUTPUT(NL)="Selected Codes:"
+48 SET TERM=""
+49 FOR
SET TERM=$ORDER(^PXD(811.2,IEN,20,"B",TERM))
if TERM=""
QUIT
Begin DoDot:1
+50 SET NL=NL+1
SET OUTPUT(NL)=""
+51 SET TEXT="Lexicon Search Term/Code: "_TERM
+52 DO COLFMT^PXRMTEXT(RM_"L",TEXT," ",.NOUT,.TEXTOUT)
+53 FOR IND=1:1:NOUT
SET NL=NL+1
SET OUTPUT(NL)=TEXTOUT(IND)
+54 SET CODESYS=""
+55 FOR
SET CODESYS=$ORDER(^PXD(811.2,IEN,20,"ATCC",TERM,CODESYS))
if CODESYS=""
QUIT
Begin DoDot:2
+56 SET NL=NL+1
SET OUTPUT(NL)=""
+57 ;DBIA #5679
+58 SET NL=NL+1
SET OUTPUT(NL)="Coding System: "_CODESYSN(CODESYS)
+59 KILL OCL
+60 SET CODE=""
+61 FOR
SET CODE=$ORDER(^PXD(811.2,IEN,20,"ATCC",TERM,CODESYS,CODE))
if CODE=""
QUIT
Begin DoDot:3
+62 SET OCL(CODE_" ")=CODE_U_^PXD(811.2,IEN,20,"ATCC",TERM,CODESYS,CODE)
+63 SET NCODES(CODESYS)=NCODES(CODESYS)+1
+64 SET ^TMP($JOB,"CC",CODE)=$GET(^TMP($JOB,"CC",CODE))+1
+65 SET ^TMP($JOB,"CC",CODE,CODESYS,TERM)=""
End DoDot:3
+66 SET CODEP=""
+67 SET NL=NL+1
SET OUTPUT(NL)=CHDR(1)
+68 SET NL=NL+1
SET OUTPUT(NL)=CHDR(2)
+69 FOR
SET CODEP=$ORDER(OCL(CODEP))
if CODEP=""
QUIT
Begin DoDot:3
+70 SET CODE=$PIECE(OCL(CODEP),U,1)
SET UID=$PIECE(OCL(CODEP),U,2)
+71 IF TYPE="C"
DO CDETAILC(CODESYS,CODE,UID,.NL,.OUTPUT)
+72 IF TYPE="F"
DO CDETAILF(CODESYS,CODE,UID,.NL,.OUTPUT)
End DoDot:3
End DoDot:2
+73 SET NL=NL+1
SET OUTPUT(NL)=""
End DoDot:1
+74 ;
+75 ;Look for duplicated codes if there are any list them.
+76 SET CODE=""
+77 FOR
SET CODE=$ORDER(^TMP($JOB,"CC",CODE))
if CODE=""
QUIT
Begin DoDot:1
+78 IF ^TMP($JOB,"CC",CODE)>1
SET DUPL(CODE)=^TMP($JOB,"CC",CODE)
End DoDot:1
+79 ;
+80 ;If there are duplicates count the number of unique codes.
+81 IF $DATA(DUPL)
Begin DoDot:1
+82 SET CODESYS=""
SET NUCODES=0
+83 FOR
SET CODESYS=$ORDER(^PXD(811.2,IEN,20,"AE",CODESYS))
if CODESYS=""
QUIT
Begin DoDot:2
+84 SET CODE=""
+85 FOR
SET CODE=$ORDER(^PXD(811.2,IEN,20,"AE",CODESYS,CODE))
if CODE=""
QUIT
Begin DoDot:3
+86 SET NUCODES(CODESYS)=NUCODES(CODESYS)+1
SET NUCODES=NUCODES+1
End DoDot:3
End DoDot:2
End DoDot:1
+87 ;
+88 SET NL=NL+1
SET OUTPUT(NL)=""
+89 SET NL=NL+1
SET OUTPUT(NL)="This taxonomy includes the following numbers of codes:"
+90 SET CODESYS=""
SET TEMP=0
+91 FOR
SET CODESYS=$ORDER(NCODES(CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+92 SET NL=NL+1
SET OUTPUT(NL)=CODESYSN(CODESYS)_": "_NCODES(CODESYS)
+93 IF $DATA(DUPL)
SET OUTPUT(NL)=OUTPUT(NL)_"; "_NUCODES(CODESYS)_" are unique."
+94 SET TEMP=TEMP+NCODES(CODESYS)
End DoDot:1
+95 SET NL=NL+1
SET OUTPUT(NL)="Total number of codes: "_TEMP
+96 IF $DATA(DUPL)
SET OUTPUT(NL)=OUTPUT(NL)_"; "_NUCODES_" are unique."
+97 ;
+98 ;If there are duplicates, list them.
+99 IF '$DATA(DUPL)
KILL ^TMP($JOB,"CC")
QUIT
+100 SET NL=NL+1
SET OUTPUT(NL)=""
+101 SET NL=NL+1
SET OUTPUT(NL)="The following codes are included in more than one Term/Code."
+102 SET CODE=""
+103 FOR
SET CODE=$ORDER(DUPL(CODE))
if CODE=""
QUIT
Begin DoDot:1
+104 SET CODESYS=""
+105 FOR
SET CODESYS=$ORDER(^TMP($JOB,"CC",CODE,CODESYS))
if CODESYS=""
QUIT
Begin DoDot:2
+106 SET NL=NL+1
SET OUTPUT(NL)=CODESYSN(CODESYS)_" code "_CODE_" is included "_DUPL(CODE)_" times."
+107 SET NL=NL+1
SET OUTPUT(NL)=" Term/Code:"
+108 SET TERM=""
+109 FOR
SET TERM=$ORDER(^TMP($JOB,"CC",CODE,CODESYS,TERM))
if TERM=""
QUIT
Begin DoDot:3
+110 SET NL=NL+1
SET OUTPUT(NL)=" "_TERM
End DoDot:3
End DoDot:2
+111 SET NL=NL+1
SET OUTPUT(NL)=""
End DoDot:1
+112 KILL ^TMP($JOB,"CC")
+113 QUIT
+114 ;
