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

PXRMTXIN.m

Go to the documentation of this file.
  1. PXRMTXIN ;SLC/PKR - Taxonomy inquiry for general use. ;01/29/2015
  1. ;;2.0;CLINICAL REMINDERS;**26,47**;Feb 04, 2005;Build 291
  1. ;==========================================
  1. BTAXALL ;Taxonomy inquiry, return the formatted text OUTPUT.
  1. N BOP,IEN,NAME,OUTPUT,TYPE
  1. S TYPE=$$GTYPE
  1. S BOP=$$BORP^PXRMUTIL("B")
  1. I BOP="" Q
  1. S NAME=""
  1. F S NAME=$O(^PXD(811.2,"B",NAME)) Q:NAME="" D
  1. . S IEN=$O(^PXD(811.2,"B",NAME,""))
  1. . D TAXINQ(TYPE,IEN,.OUTPUT)
  1. . I BOP="B" D BROWSE^DDBR("OUTPUT","NR","Taxonomy Inquiry")
  1. . I BOP="P" D GPRINT^PXRMUTIL("OUTPUT")
  1. Q
  1. ;
  1. ;==========================================
  1. BTAXINQ(IEN) ;Display a Taxonomy inquiry, defaults to the Browswer.
  1. N BOP,DIR0,OUTPUT,TITLE,TYPE
  1. I '$D(^PXD(811.2,IEN)) Q
  1. S TYPE=$$GTYPE
  1. S TITLE="Taxonomy Inquiry - "_$S(TYPE="C":"Condensed",TYPE="F":"Full",1:"")
  1. D TAXINQ(TYPE,IEN,.OUTPUT)
  1. S BOP=$$BORP^PXRMUTIL("B")
  1. I BOP="" Q
  1. I BOP="B" D BROWSE^DDBR("OUTPUT","NR",TITLE)
  1. I BOP="P" D GPRINT^PXRMUTIL("OUTPUT")
  1. Q
  1. ;
  1. ;==========================================
  1. CDETAILC(CODESYS,CODE,UID,NL,OUTPUT) ;Get the condensed details about a code.
  1. N ACTDT,DESC,HIER,INACT,INACTDT,LDESC,LHIER,LTEXT,NOLEX,PDATA,TEXT
  1. S UID=$S(UID=1:"X",1:" ")
  1. D CDETAILS(CODESYS,CODE,.NOLEX,.PDATA)
  1. S ACTDT=1000101
  1. F S ACTDT=$O(PDATA(ACTDT)) Q:ACTDT="" D
  1. . S INACTDT=$P(PDATA(ACTDT),U,1)
  1. . S INACT=$S((ACTDT>DT):"X",(INACTDT=""):" ",(INACTDT'>DT):"X",1:" ")
  1. . S DESC=$S(NOLEX=1:$P(PDATA(ACTDT),U,2),1:PDATA(ACTDT,0))
  1. . S LDESC=$L(DESC)
  1. . I (LDESC>51),(CODESYS'="SCT") S DESC=$E(DESC,1,47)_"..."
  1. . I CODESYS="SCT" D
  1. .. S HIER=$$SCTHIER(CODE,ACTDT),LHIER=$L(HIER)
  1. .. I (LDESC+LHIER)'>50 S DESC=DESC_" "_HIER
  1. .. E S DESC=$E(DESC,1,(46-LHIER))_"... "_HIER
  1. . S TEXT=CODE,LTEXT=$L(TEXT)
  1. . S TEXT=TEXT_$$REPEAT^XLFSTR(" ",(22-LTEXT))_INACT,LTEXT=$L(TEXT)
  1. . S TEXT=TEXT_$$REPEAT^XLFSTR(" ",(27-LTEXT))_UID,LTEXT=$L(TEXT)
  1. . S TEXT=TEXT_$$REPEAT^XLFSTR(" ",(30-LTEXT))_DESC
  1. . S NL=NL+1,OUTPUT(NL)=TEXT
  1. Q
  1. ;
  1. ;==========================================
  1. CDETAILF(CODESYS,CODE,UID,NL,OUTPUT) ;Get the full details about a code.
  1. N ACTDT,DESC,FMTSTR,INACTDT,IND,NOLEX,NOUT,NP,PDATA,TEXT
  1. S FMTSTR="10L1^10C2^10C4^1C3^35L"
  1. S UID=$S(UID=1:"X",1:" ")
  1. D CDETAILS(CODESYS,CODE,.NOLEX,.PDATA)
  1. S ACTDT=1000101,NP=0
  1. F S ACTDT=$O(PDATA(ACTDT)) Q:ACTDT="" D
  1. . S NP=NP+1
  1. . S INACTDT=$P(PDATA(ACTDT),U,1)
  1. . S DESC=$S(NOLEX=1:$P(PDATA(ACTDT),U,2),1:PDATA(ACTDT,0))
  1. . I CODESYS="SCT" S DESC=DESC_" "_$$SCTHIER(CODE,ACTDT)
  1. . I NP=1 S TEXT=CODE_U_$$FMTE^XLFDT(ACTDT,"5Z")_U_$$FMTE^XLFDT(INACTDT,"5Z")_U_UID_U_DESC
  1. . I NP>1 S TEXT=U_$$FMTE^XLFDT(ACTDT,"5Z")_U_$$FMTE^XLFDT(INACTDT,"5Z")_U_UID_U_DESC
  1. . D COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NOUT,.TEXTOUT)
  1. . F IND=1:1:NOUT S NL=NL+1,OUTPUT(NL)=TEXTOUT(IND)
  1. Q
  1. ;
  1. ;==========================================
  1. CDETAILS(CODESYS,CODE,NOLEX,PDATA) ;Get the details about a code.
  1. N RESULT
  1. ;DBIA #5679
  1. S RESULT=$$PERIOD^LEXU(CODE,CODESYS,.PDATA)
  1. S NOLEX=0
  1. I +RESULT=-1 D
  1. . S NOLEX=1
  1. .;DBIA #1997, #3991
  1. . I (CODESYS="CPC")!(CODESYS="CPT") D PERIOD^ICPTAPIU(CODE,.PDATA)
  1. . I (CODESYS="ICD")!(CODESYS="ICP") D PERIOD^ICDAPIU(CODE,.PDATA)
  1. Q
  1. ;
  1. ;==========================================
  1. GTYPE() ;Prompt the user for the type of output.
  1. N DIR,POP,X,Y
  1. S DIR(0)="SA"_U_"C:Condensed;F:Full"
  1. S DIR("A")="Condensed or full inquiry? "
  1. S DIR("B")="C"
  1. D ^DIR
  1. I $D(DIROUT) S DTOUT=1
  1. I $D(DTOUT)!($D(DUOUT)) Q "F"
  1. Q Y
  1. ;
  1. ;==========================================
  1. SCTHIER(CODE,ACTDT) ;Return the SNOMED hierarchy.
  1. N FSN,HE,HIER,HS
  1. ;DBIA #5007
  1. S FSN=$$GETFSN^LEXTRAN1("SCT",CODE,ACTDT)
  1. S HS=$F(FSN,"(")
  1. S HE=$F(FSN,")",HS)
  1. S HIER=$E(FSN,HS-1,HE-1)
  1. Q HIER
  1. ;
  1. ;==========================================
  1. TAXINQ(TYPE,IEN,OUTPUT) ;Taxonomy inquiry, return the formatted text OUTPUT.
  1. ;Use 80 column output.
  1. N CHDR,CODE,CODEP,CODESYS,CODESYSN,DUPL,IND,NL,OCL,IENSTR
  1. N NCODES,NOUT,NPAD,NUCODES,RM,T100,TEMP,TERM,TEXT,TEXTOUT
  1. N UID,WPARRAY
  1. S RM=80
  1. I TYPE="C" D
  1. . S CHDR(1)="Code INACT UID Description"
  1. . S CHDR(2)="------------------ ----- --- -----------"
  1. I TYPE="F" D
  1. . S CHDR(1)="Code Activation Inactivation UID Description"
  1. . S CHDR(2)="--------- ---------- ------------ --- -----------"
  1. S TEMP=^PXD(811.2,IEN,0)
  1. S IENSTR="No. "_IEN
  1. S OUTPUT(1)=$$REPEAT^XLFSTR("-",RM)
  1. S TEXT=$P(TEMP,U,1)
  1. S NPAD=RM-$L(TEXT)-1
  1. S OUTPUT(2)=TEXT_$$RJ^XLFSTR(IENSTR,NPAD," ")
  1. S OUTPUT(3)=$$REPEAT^XLFSTR("-",RM)
  1. S OUTPUT(4)=""
  1. S T100=^PXD(811.2,IEN,100)
  1. S OUTPUT(5)="Class: "_$$GET1^DIQ(811.2,IEN,100)
  1. S OUTPUT(6)="Sponsor: "_$$GET1^DIQ(811.2,IEN,101)
  1. S OUTPUT(7)="Review Date: "_$$GET1^DIQ(811.2,IEN,102)
  1. S OUTPUT(8)=""
  1. S OUTPUT(9)="Description:"
  1. S NL=9
  1. S TEMP=$$GET1^DIQ(811.2,IEN,2,"","WPARRAY")
  1. I TEMP="" S NL=NL+1,OUTPUT(NL)=""
  1. I TEMP="WPARRAY" D
  1. . S IND=0
  1. . F S IND=$O(WPARRAY(IND)) Q:IND="" S NL=NL+1,OUTPUT(NL)=WPARRAY(IND)
  1. . K WPARRAY
  1. . S NL=NL+1,OUTPUT(NL)=""
  1. S TEMP=$G(^PXD(811.2,IEN,40))
  1. S NL=NL+1,OUTPUT(NL)="Inactive Flag: "_$$GET1^DIQ(811.2,IEN,1.6)
  1. S NL=NL+1,OUTPUT(NL)="Patient Data Source: "_$$GET1^DIQ(811.2,IEN,4)
  1. S NL=NL+1,OUTPUT(NL)="Use Inactive Problems: "_$$GET1^DIQ(811.2,IEN,10)
  1. ;Initialze the code counter.
  1. K ^TMP($J,"CC")
  1. S CODESYS=""
  1. F S CODESYS=$O(^PXD(811.2,IEN,20,"AE",CODESYS)) Q:CODESYS="" D
  1. . S (NCODES(CODESYS),NUCODES(CODESYS))=0
  1. .;DBIA #5679
  1. . I '$D(CODESYSN(CODESYS)) S CODESYSN(CODESYS)=$P($$CSYS^LEXU(CODESYS),U,4)
  1. ;Display the selected codes.
  1. S NL=NL+1,OUTPUT(NL)=""
  1. S NL=NL+1,OUTPUT(NL)="Selected Codes:"
  1. S TERM=""
  1. F S TERM=$O(^PXD(811.2,IEN,20,"B",TERM)) Q:TERM="" D
  1. . S NL=NL+1,OUTPUT(NL)=""
  1. . S TEXT="Lexicon Search Term/Code: "_TERM
  1. . D COLFMT^PXRMTEXT(RM_"L",TEXT," ",.NOUT,.TEXTOUT)
  1. . F IND=1:1:NOUT S NL=NL+1,OUTPUT(NL)=TEXTOUT(IND)
  1. . S CODESYS=""
  1. . F S CODESYS=$O(^PXD(811.2,IEN,20,"ATCC",TERM,CODESYS)) Q:CODESYS="" D
  1. .. S NL=NL+1,OUTPUT(NL)=""
  1. ..;DBIA #5679
  1. .. S NL=NL+1,OUTPUT(NL)="Coding System: "_CODESYSN(CODESYS)
  1. .. K OCL
  1. .. S CODE=""
  1. .. F S CODE=$O(^PXD(811.2,IEN,20,"ATCC",TERM,CODESYS,CODE)) Q:CODE="" D
  1. ... S OCL(CODE_" ")=CODE_U_^PXD(811.2,IEN,20,"ATCC",TERM,CODESYS,CODE)
  1. ... S NCODES(CODESYS)=NCODES(CODESYS)+1
  1. ... S ^TMP($J,"CC",CODE)=$G(^TMP($J,"CC",CODE))+1
  1. ... S ^TMP($J,"CC",CODE,CODESYS,TERM)=""
  1. .. S CODEP=""
  1. .. S NL=NL+1,OUTPUT(NL)=CHDR(1)
  1. .. S NL=NL+1,OUTPUT(NL)=CHDR(2)
  1. .. F S CODEP=$O(OCL(CODEP)) Q:CODEP="" D
  1. ... S CODE=$P(OCL(CODEP),U,1),UID=$P(OCL(CODEP),U,2)
  1. ... I TYPE="C" D CDETAILC(CODESYS,CODE,UID,.NL,.OUTPUT)
  1. ... I TYPE="F" D CDETAILF(CODESYS,CODE,UID,.NL,.OUTPUT)
  1. . S NL=NL+1,OUTPUT(NL)=""
  1. ;
  1. ;Look for duplicated codes if there are any list them.
  1. S CODE=""
  1. F S CODE=$O(^TMP($J,"CC",CODE)) Q:CODE="" D
  1. . I ^TMP($J,"CC",CODE)>1 S DUPL(CODE)=^TMP($J,"CC",CODE)
  1. ;
  1. ;If there are duplicates count the number of unique codes.
  1. I $D(DUPL) D
  1. . S CODESYS="",NUCODES=0
  1. . F S CODESYS=$O(^PXD(811.2,IEN,20,"AE",CODESYS)) Q:CODESYS="" D
  1. .. S CODE=""
  1. .. F S CODE=$O(^PXD(811.2,IEN,20,"AE",CODESYS,CODE)) Q:CODE="" D
  1. ... S NUCODES(CODESYS)=NUCODES(CODESYS)+1,NUCODES=NUCODES+1
  1. ;
  1. S NL=NL+1,OUTPUT(NL)=""
  1. S NL=NL+1,OUTPUT(NL)="This taxonomy includes the following numbers of codes:"
  1. S CODESYS="",TEMP=0
  1. F S CODESYS=$O(NCODES(CODESYS)) Q:CODESYS="" D
  1. . S NL=NL+1,OUTPUT(NL)=CODESYSN(CODESYS)_": "_NCODES(CODESYS)
  1. . I $D(DUPL) S OUTPUT(NL)=OUTPUT(NL)_"; "_NUCODES(CODESYS)_" are unique."
  1. . S TEMP=TEMP+NCODES(CODESYS)
  1. S NL=NL+1,OUTPUT(NL)="Total number of codes: "_TEMP
  1. I $D(DUPL) S OUTPUT(NL)=OUTPUT(NL)_"; "_NUCODES_" are unique."
  1. ;
  1. ;If there are duplicates, list them.
  1. I '$D(DUPL) K ^TMP($J,"CC") Q
  1. S NL=NL+1,OUTPUT(NL)=""
  1. S NL=NL+1,OUTPUT(NL)="The following codes are included in more than one Term/Code."
  1. S CODE=""
  1. F S CODE=$O(DUPL(CODE)) Q:CODE="" D
  1. . S CODESYS=""
  1. . F S CODESYS=$O(^TMP($J,"CC",CODE,CODESYS)) Q:CODESYS="" D
  1. .. S NL=NL+1,OUTPUT(NL)=CODESYSN(CODESYS)_" code "_CODE_" is included "_DUPL(CODE)_" times."
  1. .. S NL=NL+1,OUTPUT(NL)=" Term/Code:"
  1. .. S TERM=""
  1. .. F S TERM=$O(^TMP($J,"CC",CODE,CODESYS,TERM)) Q:TERM="" D
  1. ... S NL=NL+1,OUTPUT(NL)=" "_TERM
  1. . S NL=NL+1,OUTPUT(NL)=""
  1. K ^TMP($J,"CC")
  1. Q
  1. ;