- PXRMVSTX ;SLC/PKR - Routines for building taxonomies for value sets. ;09/16/2014
- ;;2.0;CLINICAL REMINDERS;**47**;Feb 04, 2005;Build 291
- ;==========================================
- BLDCODEL(VSIEN,TAXIEN) ;Populate the code list.
- N CODE,CSYSIEN,IND,JND,LEXSAB,SAVEOK,TC
- K ^TMP("PXRMCODES",$J)
- S IND=0
- F S IND=+$O(^PXRM(802.2,VSIEN,2,IND)) Q:IND=0 D
- . S CSYSIEN=^PXRM(802.2,VSIEN,2,IND,0)
- . S LEXSAB=$P(^PXRM(802.1,CSYSIEN,0),U,4)
- .;DBIA #5679
- . S TC=$P($$CSYS^LEXU(LEXSAB),U,4)_" codes from value set (imported)"
- . S JND=0
- . F S JND=+$O(^PXRM(802.2,VSIEN,2,IND,1,JND)) Q:JND=0 D
- .. S CODE=^PXRM(802.2,VSIEN,2,IND,1,JND,0)
- .. I $$CHKCODE(LEXSAB,CODE)=-1 Q
- .. S ^TMP("PXRMCODES",$J,TC,LEXSAB,CODE)=""
- ;Format is: ^TMP("PXRMCODES",$J,TC,CODESYS,CODE)=UID
- S SAVEOK=$$SAVETC^PXRMTXIM(TAXIEN)
- I 'SAVEOK W !,"Could not save terms."
- I SAVEOK D POSTSAVE^PXRMTXSM(TAXIEN)
- Q
- ;
- ;==========================================
- BLDTAX(VSIEN) ;Build a taxonony from a value set.
- N DESC,ERRMSG,NAME,OID,TXDATA,VSNAME
- I '$$SCSYS(VSIEN) H 2 Q
- ;Get the name of the taxonomy to create.
- S NAME=$$GETNAME(VSIEN)
- I (NAME="^")!(NAME="") Q
- S OID=$P(^PXRM(802.2,VSIEN,1),U,1)
- S VDATE=$P(^PXRM(802.2,VSIEN,1),U,3)
- S DESC(1,0)="This taxonomy was automatically generated from the value set:"
- S DESC(2,0)=" "_$P(^PXRM(802.2,VSIEN,0),U,1)
- S DESC(3,0)=" OID - "_OID
- S DESC(4,0)=" Version Date - "_$$FMTE^XLFDT(VDATE)
- S TXDATA("NAME")=NAME
- S TXDATA("CLASS")="L"
- M TXDATA("DESC")=DESC
- S TXDATA("OID")=OID
- S TXDATA("VERSION DATE")=VDATE
- S TAXIEN=$$CRETAX^PXRMTXIM("E",.TXDATA,.ERRMSG)
- I TAXIEN=0 H 2 Q
- W !,"Created taxonomy ",NAME
- W !,"Populating the code list ..."
- ;Populate the code list.
- D BLDCODEL(VSIEN,TAXIEN)
- ;Initialize the Change Log.
- D INICLOG(TAXIEN,.DESC)
- H 2
- Q
- ;
- ;==========================================
- CHKCODE(LEXSAB,CODE) ;Verify that a code is in the Lexicon.
- N CDATA,PDATA,RESULT
- ;DBIA #5679
- S RESULT=$$CSDATA^LEXU(CODE,LEXSAB,DT,.CDATA)
- S RESULT=$$PERIOD^LEXU(CODE,LEXSAB,.PDATA)
- I +RESULT=-1 D
- . W !,"Lexicon does not recognize the ",LEXSAB," code: ",CODE
- . W !,"It will not be added to the taxonomy."
- Q +RESULT
- ;
- ;==========================================
- CMPALL(OUTTYPE) ;Find all taxonomies generated from a value set and compare
- ;the codes in the taxonomy with those in the most recent version of
- ;the value set.
- N NL,OUTPUT,TAXIEN,VSOID
- S NL=0
- S VSOID=""
- F S VSOID=$O(^PXD(811.2,"VSOID",VSOID)) Q:VSOID="" D
- . S TAXIEN=""
- . F S TAXIEN=$O(^PXD(811.2,"VSOID",VSOID,TAXIEN)) Q:TAXIEN="" D
- .. D CMPTXVS(TAXIEN,VSOID,.NL,.OUTPUT)
- I OUTTYPE="B" D BROWSE^DDBR("OUTPUT","NR","Taxonomy Value Set Code Comparison")
- I OUTTYPE="M" D
- . N IND,SUBJECT,TO
- . S SUBJECT="VALUE SETS WERE UPDATED"
- . S TO(DUZ)=""
- . K ^TMP("PXRMXMZ",$J)
- .;MailMan has a built-in width of 79.
- . F IND=1:1:NL S ^TMP("PXRMXMZ",$J,IND,0)=$E(OUTPUT(IND),1,79)
- . D SEND^PXRMMSG("PXRMXMZ",SUBJECT,.TO,DUZ)
- . K ^TMP("PXRMXMZ",$J)
- Q
- ;
- ;==========================================
- CMPTXVS(TAXIEN,VSOID,NL,OUTPUT) ;For taxonomies that were generated from a
- ;value set compare the codes in the most recent version of the
- ;value set to the codes in the taxonomy.
- I $P($G(^PXD(811.2,TAXIEN,40)),U,1)'=VSOID Q
- N CODE,CODESYS,TAXNAME,TAXVDATE,UID,VDATE,VSIEN,VSNAME
- S VSIEN=$O(^PXRM(802.2,"OID",VSOID,""),-1)
- S VSNAME=$P(^PXRM(802.2,VSIEN,0),U,1)
- S VDATE=$P(^PXRM(802.2,VSIEN,1),U,3)
- S TAXNAME=$P(^PXD(811.2,TAXIEN,0),U,1)
- S TAXVDATE=$P(^PXD(811.2,TAXIEN,40),U,2)
- S NL=NL+1,OUTPUT(NL)=""
- S NL=NL+1,OUTPUT(NL)="Checking taxonomy "_TAXNAME
- S NL=NL+1,OUTPUT(NL)=" It was generated from the value set:"
- S NL=NL+1,OUTPUT(NL)=" "_VSNAME
- S NL=NL+1,OUTPUT(NL)=" OID - "_VSOID
- S NL=NL+1,OUTPUT(NL)=" The most recent version of the value set is dated "_$$FMTE^XLFDT(VDATE)_"."
- S NL=NL+1,OUTPUT(NL)=" The taxonomy was generated from the version dated "_$$FMTE^XLFDT(TAXVDATE)_"."
- I TAXVDATE'=VDATE S NL=NL+1,OUTPUT(NL)=" The comparison is being made with the most recent version of the value set."
- ;Build a list of codes in the value set in the same structure as the
- ;"AE" index in the taxonomy. ^TMP($J,"VSCODES")
- D GVSCODES(VSIEN,"VSCODES")
- K ^TMP($J,"TAXCODES")
- M ^TMP($J,"TAXCODES")=^PXD(811.2,TAXIEN,20,"AE")
- ;Compare the two lists of codes, keep the differences.
- S CODESYS=""
- F S CODESYS=$O(^TMP($J,"TAXCODES",CODESYS)) Q:CODESYS="" D
- . S CODE=""
- . F S CODE=$O(^TMP($J,"TAXCODES",CODESYS,CODE)) Q:CODE="" D
- .. I $D(^TMP($J,"VSCODES",CODESYS,CODE)) K ^TMP($J,"VSCODES",CODESYS,CODE),^TMP($J,"TAXCODES",CODESYS,CODE)
- ;
- ;Create the result output.
- I $D(^TMP($J,"TAXCODES")) D
- . S NL=NL+1,OUTPUT(NL)=""
- . S NL=NL+1,OUTPUT(NL)="The following codes are in the taxonomy but not in the value set:"
- . S CODESYS=""
- . F S CODESYS=$O(^TMP($J,"TAXCODES",CODESYS)) Q:CODESYS="" D
- .. S NL=NL+1,OUTPUT(NL)="Coding system "_$P($$CSYS^LEXU(CODESYS),U,4)
- .. S NL=NL+1,OUTPUT(NL)="Code INACT UID Description"
- .. S NL=NL+1,OUTPUT(NL)="------------------ ----- --- -----------"
- .. S CODE=""
- .. F S CODE=$O(^TMP($J,"TAXCODES",CODESYS,CODE)) Q:CODE="" D
- ... S UID=$S($D(^PXD(811.2,TAXIEN,20,"AUID",CODESYS,CODE)):1,1:0)
- ... D CDETAILC^PXRMTXIN(CODESYS,CODE,UID,.NL,.OUTPUT)
- I $D(^TMP($J,"VSCODES")) D
- . S NL=NL+1,OUTPUT(NL)=""
- . S NL=NL+1,OUTPUT(NL)="The following codes are in the value set but not in the taxonomy:"
- . S CODESYS=""
- . F S CODESYS=$O(^TMP($J,"VSCODES",CODESYS)) Q:CODESYS="" D
- .. S NL=NL+1,OUTPUT(NL)="Coding system "_$P($$CSYS^LEXU(CODESYS),U,4)
- .. S NL=NL+1,OUTPUT(NL)="Code INACT Description"
- .. S NL=NL+1,OUTPUT(NL)="------------------ ----- -----------"
- .. S CODE=""
- .. F S CODE=$O(^TMP($J,"VSCODES",CODESYS,CODE)) Q:CODE="" D
- ... D CDETAILC^PXRMTXIN(CODESYS,CODE,"",.NL,.OUTPUT)
- I '$D(^TMP($J,"TAXCODES")),'$D(^TMP($J,"VSCODES")) D
- . S NL=NL+1,OUTPUT(NL)=""
- . S NL=NL+1,OUTPUT(NL)="The list of codes in the taxonomy is identical to the list of codes in the"
- . S NL=NL+1,OUTPUT(NL)="value set."
- S NL=NL+1,OUTPUT(NL)=""
- K ^TMP($J,"TAXCODES"),^TMP($J,"VSCODES")
- Q
- ;
- ;==========================================
- GVSCODES(VSIEN,NODE) ;Get the codes in a value set.
- N CODE,CSYSIEN,IND,JND,LEXSAB
- K ^TMP($J,NODE)
- S IND=0
- F S IND=+$O(^PXRM(802.2,VSIEN,2,IND)) Q:IND=0 D
- . S CSYSIEN=^PXRM(802.2,VSIEN,2,IND,0)
- . S LEXSAB=$P(^PXRM(802.1,CSYSIEN,0),U,4)
- . S JND=0
- . F S JND=+$O(^PXRM(802.2,VSIEN,2,IND,1,JND)) Q:JND=0 D
- .. S CODE=^PXRM(802.2,VSIEN,2,IND,1,JND,0)
- .. S ^TMP($J,NODE,LEXSAB,CODE)=""
- Q
- ;
- ;==========================================
- GETNAME(VSIEN) ;
- N DIR,FIELDLEN,NAME,TEXT,VSNAME,X,Y
- S VSNAME=$P(^PXRM(802.2,VSIEN,0),U,1)
- S VSNAME=$$UP^XLFSTR(VSNAME)
- S FIELDLEN=$$GET1^DID(811.2,.01,"","FIELD LENGTH")
- S DIR(0)="F"_U_"3:"_FIELDLEN_U_"K:(X?.N)!'(X'?1P.E) X"
- S DIR("A")="Please enter the taxonomy name"
- I $L(VSNAME)'>FIELDLEN S DIR("B")=VSNAME
- GETNAM W ! D ^DIR
- S NAME=Y
- ;Make sure the new name is valid.
- I $D(^PXD(811.2,"B",NAME)) D G GETNAM
- . S TEXT(1)="A taxonomy named "_NAME_" already exists!"
- . S TEXT(2)="Please choose a unique name."
- . D EN^DDIOL(.TEXT)
- I '$$VNAME^PXRMINTR(NAME) G GETNAM
- Q NAME
- ;
- ;==========================================
- INICLOG(IEN,TEXT) ;Initialize the change log.
- N IENS,FDA,FDAIEN,MSG
- S IENS="+1,"_IEN_","
- S FDA(811.21,IENS,.01)=$$NOW^XLFDT
- S FDA(811.21,IENS,1)=DUZ
- S FDA(811.21,IENS,2)="TEXT"
- D UPDATE^DIE("S","FDA","FDAIEN","MSG")
- Q
- ;
- ;==========================================
- SCSYS(VSIEN) ;Scan the coding systems in the value set to determine if it
- ;contains any supported coding systems.
- N CSYSIEN,LEXSAB,OK,NCSYS,TEMP
- W !,"Scanning the coding systems used in the value set ..."
- S NCSYS=+$P(^PXRM(802.2,VSIEN,2,0),U,3)
- I NCSYS=0 D Q 0
- . W !,"No coding systems were found, cannot create a taxonomy."
- . H 2
- S IND=0,OK=0
- F S IND=+$O(^PXRM(802.2,VSIEN,2,IND)) Q:IND=0 D
- . S CSYSIEN=^PXRM(802.2,VSIEN,2,IND,0)
- . S TEMP=^PXRM(802.1,CSYSIEN,0)
- . S LEXSAB=$P(TEMP,U,4)
- . I LEXSAB="" W !," ",$P(TEMP,U,1)," is not a supported coding system." Q
- . I $$VCSYS^PXRMTAXD(LEXSAB) S OK=1 W !," Will import ",$P(TEMP,U,1)," codes into the taxonomy."
- I 'OK W !,"No supported coding systems were found, cannot create a taxonomy." H 2
- Q OK
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMVSTX 8468 printed Feb 18, 2025@23:16:26 Page 2
- PXRMVSTX ;SLC/PKR - Routines for building taxonomies for value sets. ;09/16/2014
- +1 ;;2.0;CLINICAL REMINDERS;**47**;Feb 04, 2005;Build 291
- +2 ;==========================================
- BLDCODEL(VSIEN,TAXIEN) ;Populate the code list.
- +1 NEW CODE,CSYSIEN,IND,JND,LEXSAB,SAVEOK,TC
- +2 KILL ^TMP("PXRMCODES",$JOB)
- +3 SET IND=0
- +4 FOR
- SET IND=+$ORDER(^PXRM(802.2,VSIEN,2,IND))
- if IND=0
- QUIT
- Begin DoDot:1
- +5 SET CSYSIEN=^PXRM(802.2,VSIEN,2,IND,0)
- +6 SET LEXSAB=$PIECE(^PXRM(802.1,CSYSIEN,0),U,4)
- +7 ;DBIA #5679
- +8 SET TC=$PIECE($$CSYS^LEXU(LEXSAB),U,4)_" codes from value set (imported)"
- +9 SET JND=0
- +10 FOR
- SET JND=+$ORDER(^PXRM(802.2,VSIEN,2,IND,1,JND))
- if JND=0
- QUIT
- Begin DoDot:2
- +11 SET CODE=^PXRM(802.2,VSIEN,2,IND,1,JND,0)
- +12 IF $$CHKCODE(LEXSAB,CODE)=-1
- QUIT
- +13 SET ^TMP("PXRMCODES",$JOB,TC,LEXSAB,CODE)=""
- End DoDot:2
- End DoDot:1
- +14 ;Format is: ^TMP("PXRMCODES",$J,TC,CODESYS,CODE)=UID
- +15 SET SAVEOK=$$SAVETC^PXRMTXIM(TAXIEN)
- +16 IF 'SAVEOK
- WRITE !,"Could not save terms."
- +17 IF SAVEOK
- DO POSTSAVE^PXRMTXSM(TAXIEN)
- +18 QUIT
- +19 ;
- +20 ;==========================================
- BLDTAX(VSIEN) ;Build a taxonony from a value set.
- +1 NEW DESC,ERRMSG,NAME,OID,TXDATA,VSNAME
- +2 IF '$$SCSYS(VSIEN)
- HANG 2
- QUIT
- +3 ;Get the name of the taxonomy to create.
- +4 SET NAME=$$GETNAME(VSIEN)
- +5 IF (NAME="^")!(NAME="")
- QUIT
- +6 SET OID=$PIECE(^PXRM(802.2,VSIEN,1),U,1)
- +7 SET VDATE=$PIECE(^PXRM(802.2,VSIEN,1),U,3)
- +8 SET DESC(1,0)="This taxonomy was automatically generated from the value set:"
- +9 SET DESC(2,0)=" "_$PIECE(^PXRM(802.2,VSIEN,0),U,1)
- +10 SET DESC(3,0)=" OID - "_OID
- +11 SET DESC(4,0)=" Version Date - "_$$FMTE^XLFDT(VDATE)
- +12 SET TXDATA("NAME")=NAME
- +13 SET TXDATA("CLASS")="L"
- +14 MERGE TXDATA("DESC")=DESC
- +15 SET TXDATA("OID")=OID
- +16 SET TXDATA("VERSION DATE")=VDATE
- +17 SET TAXIEN=$$CRETAX^PXRMTXIM("E",.TXDATA,.ERRMSG)
- +18 IF TAXIEN=0
- HANG 2
- QUIT
- +19 WRITE !,"Created taxonomy ",NAME
- +20 WRITE !,"Populating the code list ..."
- +21 ;Populate the code list.
- +22 DO BLDCODEL(VSIEN,TAXIEN)
- +23 ;Initialize the Change Log.
- +24 DO INICLOG(TAXIEN,.DESC)
- +25 HANG 2
- +26 QUIT
- +27 ;
- +28 ;==========================================
- CHKCODE(LEXSAB,CODE) ;Verify that a code is in the Lexicon.
- +1 NEW CDATA,PDATA,RESULT
- +2 ;DBIA #5679
- +3 SET RESULT=$$CSDATA^LEXU(CODE,LEXSAB,DT,.CDATA)
- +4 SET RESULT=$$PERIOD^LEXU(CODE,LEXSAB,.PDATA)
- +5 IF +RESULT=-1
- Begin DoDot:1
- +6 WRITE !,"Lexicon does not recognize the ",LEXSAB," code: ",CODE
- +7 WRITE !,"It will not be added to the taxonomy."
- End DoDot:1
- +8 QUIT +RESULT
- +9 ;
- +10 ;==========================================
- CMPALL(OUTTYPE) ;Find all taxonomies generated from a value set and compare
- +1 ;the codes in the taxonomy with those in the most recent version of
- +2 ;the value set.
- +3 NEW NL,OUTPUT,TAXIEN,VSOID
- +4 SET NL=0
- +5 SET VSOID=""
- +6 FOR
- SET VSOID=$ORDER(^PXD(811.2,"VSOID",VSOID))
- if VSOID=""
- QUIT
- Begin DoDot:1
- +7 SET TAXIEN=""
- +8 FOR
- SET TAXIEN=$ORDER(^PXD(811.2,"VSOID",VSOID,TAXIEN))
- if TAXIEN=""
- QUIT
- Begin DoDot:2
- +9 DO CMPTXVS(TAXIEN,VSOID,.NL,.OUTPUT)
- End DoDot:2
- End DoDot:1
- +10 IF OUTTYPE="B"
- DO BROWSE^DDBR("OUTPUT","NR","Taxonomy Value Set Code Comparison")
- +11 IF OUTTYPE="M"
- Begin DoDot:1
- +12 NEW IND,SUBJECT,TO
- +13 SET SUBJECT="VALUE SETS WERE UPDATED"
- +14 SET TO(DUZ)=""
- +15 KILL ^TMP("PXRMXMZ",$JOB)
- +16 ;MailMan has a built-in width of 79.
- +17 FOR IND=1:1:NL
- SET ^TMP("PXRMXMZ",$JOB,IND,0)=$EXTRACT(OUTPUT(IND),1,79)
- +18 DO SEND^PXRMMSG("PXRMXMZ",SUBJECT,.TO,DUZ)
- +19 KILL ^TMP("PXRMXMZ",$JOB)
- End DoDot:1
- +20 QUIT
- +21 ;
- +22 ;==========================================
- CMPTXVS(TAXIEN,VSOID,NL,OUTPUT) ;For taxonomies that were generated from a
- +1 ;value set compare the codes in the most recent version of the
- +2 ;value set to the codes in the taxonomy.
- +3 IF $PIECE($GET(^PXD(811.2,TAXIEN,40)),U,1)'=VSOID
- QUIT
- +4 NEW CODE,CODESYS,TAXNAME,TAXVDATE,UID,VDATE,VSIEN,VSNAME
- +5 SET VSIEN=$ORDER(^PXRM(802.2,"OID",VSOID,""),-1)
- +6 SET VSNAME=$PIECE(^PXRM(802.2,VSIEN,0),U,1)
- +7 SET VDATE=$PIECE(^PXRM(802.2,VSIEN,1),U,3)
- +8 SET TAXNAME=$PIECE(^PXD(811.2,TAXIEN,0),U,1)
- +9 SET TAXVDATE=$PIECE(^PXD(811.2,TAXIEN,40),U,2)
- +10 SET NL=NL+1
- SET OUTPUT(NL)=""
- +11 SET NL=NL+1
- SET OUTPUT(NL)="Checking taxonomy "_TAXNAME
- +12 SET NL=NL+1
- SET OUTPUT(NL)=" It was generated from the value set:"
- +13 SET NL=NL+1
- SET OUTPUT(NL)=" "_VSNAME
- +14 SET NL=NL+1
- SET OUTPUT(NL)=" OID - "_VSOID
- +15 SET NL=NL+1
- SET OUTPUT(NL)=" The most recent version of the value set is dated "_$$FMTE^XLFDT(VDATE)_"."
- +16 SET NL=NL+1
- SET OUTPUT(NL)=" The taxonomy was generated from the version dated "_$$FMTE^XLFDT(TAXVDATE)_"."
- +17 IF TAXVDATE'=VDATE
- SET NL=NL+1
- SET OUTPUT(NL)=" The comparison is being made with the most recent version of the value set."
- +18 ;Build a list of codes in the value set in the same structure as the
- +19 ;"AE" index in the taxonomy. ^TMP($J,"VSCODES")
- +20 DO GVSCODES(VSIEN,"VSCODES")
- +21 KILL ^TMP($JOB,"TAXCODES")
- +22 MERGE ^TMP($JOB,"TAXCODES")=^PXD(811.2,TAXIEN,20,"AE")
- +23 ;Compare the two lists of codes, keep the differences.
- +24 SET CODESYS=""
- +25 FOR
- SET CODESYS=$ORDER(^TMP($JOB,"TAXCODES",CODESYS))
- if CODESYS=""
- QUIT
- Begin DoDot:1
- +26 SET CODE=""
- +27 FOR
- SET CODE=$ORDER(^TMP($JOB,"TAXCODES",CODESYS,CODE))
- if CODE=""
- QUIT
- Begin DoDot:2
- +28 IF $DATA(^TMP($JOB,"VSCODES",CODESYS,CODE))
- KILL ^TMP($JOB,"VSCODES",CODESYS,CODE),^TMP($JOB,"TAXCODES",CODESYS,CODE)
- End DoDot:2
- End DoDot:1
- +29 ;
- +30 ;Create the result output.
- +31 IF $DATA(^TMP($JOB,"TAXCODES"))
- Begin DoDot:1
- +32 SET NL=NL+1
- SET OUTPUT(NL)=""
- +33 SET NL=NL+1
- SET OUTPUT(NL)="The following codes are in the taxonomy but not in the value set:"
- +34 SET CODESYS=""
- +35 FOR
- SET CODESYS=$ORDER(^TMP($JOB,"TAXCODES",CODESYS))
- if CODESYS=""
- QUIT
- Begin DoDot:2
- +36 SET NL=NL+1
- SET OUTPUT(NL)="Coding system "_$PIECE($$CSYS^LEXU(CODESYS),U,4)
- +37 SET NL=NL+1
- SET OUTPUT(NL)="Code INACT UID Description"
- +38 SET NL=NL+1
- SET OUTPUT(NL)="------------------ ----- --- -----------"
- +39 SET CODE=""
- +40 FOR
- SET CODE=$ORDER(^TMP($JOB,"TAXCODES",CODESYS,CODE))
- if CODE=""
- QUIT
- Begin DoDot:3
- +41 SET UID=$SELECT($DATA(^PXD(811.2,TAXIEN,20,"AUID",CODESYS,CODE)):1,1:0)
- +42 DO CDETAILC^PXRMTXIN(CODESYS,CODE,UID,.NL,.OUTPUT)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +43 IF $DATA(^TMP($JOB,"VSCODES"))
- Begin DoDot:1
- +44 SET NL=NL+1
- SET OUTPUT(NL)=""
- +45 SET NL=NL+1
- SET OUTPUT(NL)="The following codes are in the value set but not in the taxonomy:"
- +46 SET CODESYS=""
- +47 FOR
- SET CODESYS=$ORDER(^TMP($JOB,"VSCODES",CODESYS))
- if CODESYS=""
- QUIT
- Begin DoDot:2
- +48 SET NL=NL+1
- SET OUTPUT(NL)="Coding system "_$PIECE($$CSYS^LEXU(CODESYS),U,4)
- +49 SET NL=NL+1
- SET OUTPUT(NL)="Code INACT Description"
- +50 SET NL=NL+1
- SET OUTPUT(NL)="------------------ ----- -----------"
- +51 SET CODE=""
- +52 FOR
- SET CODE=$ORDER(^TMP($JOB,"VSCODES",CODESYS,CODE))
- if CODE=""
- QUIT
- Begin DoDot:3
- +53 DO CDETAILC^PXRMTXIN(CODESYS,CODE,"",.NL,.OUTPUT)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +54 IF '$DATA(^TMP($JOB,"TAXCODES"))
- IF '$DATA(^TMP($JOB,"VSCODES"))
- Begin DoDot:1
- +55 SET NL=NL+1
- SET OUTPUT(NL)=""
- +56 SET NL=NL+1
- SET OUTPUT(NL)="The list of codes in the taxonomy is identical to the list of codes in the"
- +57 SET NL=NL+1
- SET OUTPUT(NL)="value set."
- End DoDot:1
- +58 SET NL=NL+1
- SET OUTPUT(NL)=""
- +59 KILL ^TMP($JOB,"TAXCODES"),^TMP($JOB,"VSCODES")
- +60 QUIT
- +61 ;
- +62 ;==========================================
- GVSCODES(VSIEN,NODE) ;Get the codes in a value set.
- +1 NEW CODE,CSYSIEN,IND,JND,LEXSAB
- +2 KILL ^TMP($JOB,NODE)
- +3 SET IND=0
- +4 FOR
- SET IND=+$ORDER(^PXRM(802.2,VSIEN,2,IND))
- if IND=0
- QUIT
- Begin DoDot:1
- +5 SET CSYSIEN=^PXRM(802.2,VSIEN,2,IND,0)
- +6 SET LEXSAB=$PIECE(^PXRM(802.1,CSYSIEN,0),U,4)
- +7 SET JND=0
- +8 FOR
- SET JND=+$ORDER(^PXRM(802.2,VSIEN,2,IND,1,JND))
- if JND=0
- QUIT
- Begin DoDot:2
- +9 SET CODE=^PXRM(802.2,VSIEN,2,IND,1,JND,0)
- +10 SET ^TMP($JOB,NODE,LEXSAB,CODE)=""
- End DoDot:2
- End DoDot:1
- +11 QUIT
- +12 ;
- +13 ;==========================================
- GETNAME(VSIEN) ;
- +1 NEW DIR,FIELDLEN,NAME,TEXT,VSNAME,X,Y
- +2 SET VSNAME=$PIECE(^PXRM(802.2,VSIEN,0),U,1)
- +3 SET VSNAME=$$UP^XLFSTR(VSNAME)
- +4 SET FIELDLEN=$$GET1^DID(811.2,.01,"","FIELD LENGTH")
- +5 SET DIR(0)="F"_U_"3:"_FIELDLEN_U_"K:(X?.N)!'(X'?1P.E) X"
- +6 SET DIR("A")="Please enter the taxonomy name"
- +7 IF $LENGTH(VSNAME)'>FIELDLEN
- SET DIR("B")=VSNAME
- GETNAM WRITE !
- DO ^DIR
- +1 SET NAME=Y
- +2 ;Make sure the new name is valid.
- +3 IF $DATA(^PXD(811.2,"B",NAME))
- Begin DoDot:1
- +4 SET TEXT(1)="A taxonomy named "_NAME_" already exists!"
- +5 SET TEXT(2)="Please choose a unique name."
- +6 DO EN^DDIOL(.TEXT)
- End DoDot:1
- GOTO GETNAM
- +7 IF '$$VNAME^PXRMINTR(NAME)
- GOTO GETNAM
- +8 QUIT NAME
- +9 ;
- +10 ;==========================================
- INICLOG(IEN,TEXT) ;Initialize the change log.
- +1 NEW IENS,FDA,FDAIEN,MSG
- +2 SET IENS="+1,"_IEN_","
- +3 SET FDA(811.21,IENS,.01)=$$NOW^XLFDT
- +4 SET FDA(811.21,IENS,1)=DUZ
- +5 SET FDA(811.21,IENS,2)="TEXT"
- +6 DO UPDATE^DIE("S","FDA","FDAIEN","MSG")
- +7 QUIT
- +8 ;
- +9 ;==========================================
- SCSYS(VSIEN) ;Scan the coding systems in the value set to determine if it
- +1 ;contains any supported coding systems.
- +2 NEW CSYSIEN,LEXSAB,OK,NCSYS,TEMP
- +3 WRITE !,"Scanning the coding systems used in the value set ..."
- +4 SET NCSYS=+$PIECE(^PXRM(802.2,VSIEN,2,0),U,3)
- +5 IF NCSYS=0
- Begin DoDot:1
- +6 WRITE !,"No coding systems were found, cannot create a taxonomy."
- +7 HANG 2
- End DoDot:1
- QUIT 0
- +8 SET IND=0
- SET OK=0
- +9 FOR
- SET IND=+$ORDER(^PXRM(802.2,VSIEN,2,IND))
- if IND=0
- QUIT
- Begin DoDot:1
- +10 SET CSYSIEN=^PXRM(802.2,VSIEN,2,IND,0)
- +11 SET TEMP=^PXRM(802.1,CSYSIEN,0)
- +12 SET LEXSAB=$PIECE(TEMP,U,4)
- +13 IF LEXSAB=""
- WRITE !," ",$PIECE(TEMP,U,1)," is not a supported coding system."
- QUIT
- +14 IF $$VCSYS^PXRMTAXD(LEXSAB)
- SET OK=1
- WRITE !," Will import ",$PIECE(TEMP,U,1)," codes into the taxonomy."
- End DoDot:1
- +15 IF 'OK
- WRITE !,"No supported coding systems were found, cannot create a taxonomy."
- HANG 2
- +16 QUIT OK
- +17 ;
