- 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 Feb 18, 2025@23:15:59 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 ;