PXRMTXIM ;SLC/PKR - Taxonomy import/create routines. ;02/19/2015
;;2.0;CLINICAL REMINDERS;**26,47**;Feb 04, 2005;Build 291
;==========================================
CRETAX(FLAGS,TXDATA,ERRMSG) ;Create a taxonomy based on the data in TXDATA.
;The following TXDATA nodes are required:
;NAME, CLASS, and SOURCE.
;The SPONSOR node is optional, it is a pointer to the Sponsor file.
;Codes to include in the taxonomy are specified as
;TXDATA("CODE",CODESYS,CODEP)=FMT^UID
;where CODESYS is one of the following: 10D, 10P, CPT, ICD, ICP, SCT.
;CODEP is either the code or its IEN, except for SCT where it must be
;the code. FMT is "E" if CODEP is the code and "I" if it is the
;pointer. UID is 1 if the code can be used in a dialog and 0 or null
;if it cannot.
N CDATA,CODE,CODEP,CODESYS,CODESYST,DESC,IENS,FDA,FDAIEN,FMT,MSG
N RESULT,SAVEOK,TC,TEMP,UID
I $D(TXDATA("DESC")) M DESC=TXDATA("DESC")
E S DESC(1,0)="This taxonomy was automatically generated from "_TXDATA("SOURCE")_"."
S IENS="+1,"
S FDA(811.2,IENS,.01)=TXDATA("NAME")
S FDA(811.2,IENS,2)="DESC"
I $D(TXDATA("OID")) S FDA(811.2,IENS,40)=TXDATA("OID")
I $D(TXDATA("VERSION DATE")) S FDA(811.2,IENS,41)=TXDATA("VERSION DATE")
S FDA(811.2,IENS,100)=TXDATA("CLASS")
I $D(TXDATA("SPONSOR")) S FDA(811.2,IENS,101)=TXDATA("SPONSOR")
D UPDATE^DIE(FLAGS,"FDA","FDAIEN","MSG")
I $D(MSG) D Q 0
. N IC,EMSG,REF
. S REF="MSG"
. F IC=1:1 S REF=$Q(@REF) Q:REF="" S EMSG(IC)=REF_"="_@REF
. D BMES^XPDUTL("Could not create taxonomy named "_TXDATA("NAME"))
. D MES^XPDUTL(.EMSG)
K ^TMP("PXRMCODES",$J)
S CODESYST=""
F S CODESYST=$O(TXDATA("CODE",CODESYST)) Q:CODESYST="" D
. S CODEP=""
. F S CODEP=$O(TXDATA("CODE",CODESYST,CODEP)) Q:CODEP="" D
.. S CODESYS=CODESYST
.. S TEMP=$G(TXDATA("CODE",CODESYST,CODEP))
.. S FMT=$P(TEMP,U,1)
.. S UID=+$P(TEMP,U,2)
..;DBIA #5747
.. I (CODESYST="10D")!(CODESYS="ICD") S RESULT=$$ICDDX^ICDEX(CODEP,DT,CODESYS,FMT)
.. I (CODESYST="10P")!(CODESYS="ICP") S RESULT=$$ICDOP^ICDEX(CODEP,DT,CODESYS,FMT)
..;DBIA #1995
.. I CODESYST="CPC" S RESULT=$$CPT^ICPTCOD(CODEP)
.. I CODESYST="CPT" S RESULT=$$CPT^ICPTCOD(CODEP) I $P(RESULT,U,5)="H" S CODESYS="CPC"
.. I CODESYST="SCT" S RESULT=1_U_CODEP
.. I +RESULT=-1 S ERRMSG(CODESYS,CODEP)=$P(RESULT,U,2) Q
.. S CODE=$P(RESULT,U,2)
.. K CDATA
..;DBIA #5679
.. S RESULT=$$CSDATA^LEXU(CODE,CODESYS,DT,.CDATA)
.. S TC=$P(CDATA("LEX",1),U,2)
.. I TC="" S TC=CDATA("SYS",14,1)
.. I TC="" S ERRMSG(CODESYS,CODE)="No description found." Q
.. S ^TMP("PXRMCODES",$J,TC,CODESYS,CODE)=UID
S SAVEOK=$$SAVETC^PXRMTXIM(FDAIEN(1))
I SAVEOK D POSTSAVE^PXRMTXSM(FDAIEN(1))
Q FDAIEN(1)
;
;==========================================
IMP(IEN) ;Import codes into a taxonomy.
N CLASS,DIR,LOADOK,NATOK,OPTION,PXRMTIEN,SAVED,X,Y
S CLASS=$P(^PXD(811.2,IEN,100),U,1)
S NATOK=$S(CLASS'="N":1,1:($G(PXRMINST)=1)&($G(DUZ(0))="@"))
I 'NATOK D Q
. D EN^DDIOL("Codes cannot be imported into national taxonomies!")
. H 2
. S VALMBCK="R"
;Present the menu of import choices.
S DIR(0)="S^HF:CSV host file;"
S DIR(0)=DIR(0)_"PA:CSV file paste;"
S DIR(0)=DIR(0)_"TAX:Another taxonomy;"
S DIR(0)=DIR(0)_"WEB:CSV file from a web site"
S DIR("A")="Select the import method"
S DIR("??")="^D HELP^PXRMTXIH"
D ^DIR
S OPTION=Y
I OPTION="HF" D
. S LOADOK=$$LOADHF("TAXIMP")
. I LOADOK D
.. S SAVED=$$IMPCSV(IEN,"TAXIMP")
.. I SAVED D UPDCL(IEN,"from a host file")
I OPTION="PA" D
. D PASTECSV("TAXIMP")
. S SAVED=$$IMPCSV(IEN,"TAXIMP")
. I SAVED D UPDCL(IEN,"by pasting")
I OPTION="TAX" D
. D START^PXRMTXCE
. S SAVED=$$IMPTAX(IEN,.PXRMTIEN)
. I SAVED D UPDCL(IEN,"from other taxonomies")
I OPTION="WEB" D
. S LOADOK=$$LOADWEB("TAXIMP")
. I LOADOK D
.. S SAVED=$$IMPCSV(IEN,"TAXIMP")
.. I SAVED D UPDCL(IEN,"from a web site")
S VALMBCK="R"
Q
;
;==========================================
IMPCSV(IEN,NODE) ;Import comma separated data into the Lexicon Term/Code
;multiple. The expected format is:
;LEXICON TERM/CODE,CODING SYSTEM,CODE 1,CODE 2, .... CODE N.
I '$D(^TMP($J,NODE)) Q 0
N ANS,CODE,CODESYS,CODESYSN,DUPL,IND,JND,KND,NCODES,NL,RESULT
N SAVED,SAVEOK,TEMP,TERM,TEXT,TEXTOUT
K ^TMP($J,"CC")
S (IND,NL,SAVED)=0
D EN^DDIOL("Starting the import process ... ")
F S IND=$O(^TMP($J,NODE,IND)) Q:IND="" D
. S TEMP=^TMP($J,NODE,IND,1)
. I '$$ISCSV(TEMP) Q
. S TERM=$P(TEMP,",",1)
. I (TERM="")!(TERM="^") Q
. S TERM=TERM_" (imported)"
. I IND>1 S NL=NL+1,TEXTOUT(NL)=""
. S NL=NL+1,TEXTOUT(NL)="Term/Code: "_TERM
. S CODESYS=$P(TEMP,",",2)
.;DBIA #5679
. I '$D(CODESYSN(CODESYS)) S CODESYSN(CODESYS)=$P($$CSYS^LEXU(CODESYS),U,4)
.;Make sure it is a valid Lexicon coding system.
.;DBIA #5679
. S RESULT=$$CSYS^LEXU(CODESYS)
. I +RESULT=-1 D
.. S TEXT=" Coding System: "_CODESYS_" not found in Lexicon."
.. D EN^DDIOL(TEXT)
. I +RESULT'=-1 D
.. S TEXT=" Coding System: "_$P(RESULT,U,4)
.. I '$D(NCODES(CODESYS)) S NCODES(CODESYS)=0
. S NL=NL+1,TEXTOUT(NL)=TEXT
. I +RESULT=-1 Q
.;Make sure it is a valid taxonomy coding system.
. I '$$VCODESYS^PXRMLEX(CODESYS) S NL=NL+1,TEXTOUT(NL)=" Warning taxonomies do not use "_CODESYS_" codes." Q
. S NCODES=0
. F JND=3:1:$L(TEMP,",") D
.. S CODE=$P(TEMP,",",JND)
.. S CODE=$TR(CODE," ","")
.. I CODE="" Q
.. S RESULT=$$PERCHK(CODE,CODESYS,TERM,.NCODES,.NL,.TEXTOUT)
.. I +RESULT=-1 D LEXCHK(CODE,CODESYS,TERM,.NCODES,.NL,.TEXTOUT)
.;Check for additional code only nodes in ^TMP.
. S JND=1
. F S JND=$O(^TMP($J,NODE,IND,JND)) Q:JND="" D
.. S TEMP=^TMP($J,NODE,IND,JND)
.. F KND=1:1:$L(TEMP,",") D
... S CODE=$P(TEMP,",",KND)
... S CODE=$TR(CODE," ","")
... I CODE="" Q
... S RESULT=$$PERCHK(CODE,CODESYS,TERM,.NCODES,.NL,.TEXTOUT)
... I +RESULT=-1 D LEXCHK(CODE,CODESYS,TERM,.NCODES,.NL,.TEXTOUT)
S NL=NL+1,TEXTOUT(NL)=""
;Look for duplicate codes.
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)
I $D(DUPL) D EN^DDIOL("This import contains duplicate codes.")
I '$D(NCODES) D Q SAVED
. D EN^DDIOL("There are no codes to import.")
. S VALMBCK="R"
. H 2
;
S ANS=$$ASKYN^PXRMEUT("Y","Do you want to browse the list of codes")
I ANS D
. S NL=NL+1,TEXTOUT(NL)=""
. S NL=NL+1,TEXTOUT(NL)="This import includes the following numbers of codes:"
. S CODESYS="",TEMP=0
. F S CODESYS=$O(NCODES(CODESYS)) Q:CODESYS="" D
.. S NL=NL+1,TEXTOUT(NL)=CODESYSN(CODESYS)_": "_NCODES(CODESYS)
.. S TEMP=TEMP+NCODES(CODESYS)
. S NL=NL+1,TEXTOUT(NL)="Total number of codes: "_TEMP
. ;If there are duplicates, list them.
. I $D(DUPL) D
.. S NL=NL+1,TEXTOUT(NL)=""
.. S NL=NL+1,TEXTOUT(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,TEXTOUT(NL)=CODESYSN(CODESYS)_" code "_CODE_" is included "_DUPL(CODE)_" times."
.... S NL=NL+1,TEXTOUT(NL)=" Term/Code:"
.... S TERM=""
.... F S TERM=$O(^TMP($J,"CC",CODE,CODESYS,TERM)) Q:TERM="" D
..... S NL=NL+1,TEXTOUT(NL)=" "_TERM
... S NL=NL+1,TEXTOUT(NL)=""
.. S NL=NL+1,TEXTOUT(NL)="After importing the codes more details can be found in the taxonomy inquiry."
. D BROWSE^DDBR("TEXTOUT","NR","List Of Codes To Be Imported")
S SAVED=0
S ANS=$$ASKYN^PXRMEUT("Y","Do you want to save the imported codes")
I ANS D
. M ^TMP("PXRMCODES",$J)=^TMP($J,"CODES")
. S SAVEOK=$$SAVETC(IEN)
. I SAVEOK D POSTSAVE^PXRMTXSM(IEN) S SAVED=1
;
K ^TMP($J,NODE),^TMP($J,"CC"),^TMP($J,"CODES")
S VALMBCK="R"
Q SAVED
;
;==========================================
IMPTAX(IEN,PXRMTIEN) ;Import codes from other taxonomies.
;Go through the list ask if some or all, if some then have to prompt
;for each term/code.
N ANS,CODESYS,DIR,IMP,IND,JND,SAVED,SAVELIST,SAVEOK
N TIEN,TERM,TEXT,TNAME,X,Y
S DIR(0)="S^ALL:All codes;"
S DIR(0)=DIR(0)_"SEL:Selected codes"
S DIR("B")="ALL"
S TIEN=0
F S TIEN=$O(PXRMTIEN(TIEN)) Q:TIEN="" D
. S TNAME=$P(^PXD(811.2,TIEN,0),U,1)
. D EN^DDIOL("Ready to import codes from taxonomy "_TNAME)
. D ^DIR
. S ANS=Y
. S IND=0
. F S IND=+$O(^PXD(811.2,TIEN,20,IND)) Q:IND=0 D
.. S TERM=^PXD(811.2,TIEN,20,IND,0)
.. S JND=0
.. F S JND=+$O(^PXD(811.2,TIEN,20,IND,1,JND)) Q:JND=0 D
... S CODESYS=$P(^PXD(811.2,TIEN,20,IND,1,JND,0),U,1)
... S IMP=$S(ANS="SEL":0,1:1)
... I ANS="SEL" D
.... S TEXT(1)=""
.... S TEXT(2)="Import codes from:"
.... S TEXT(3)=" Term/Code - "_TERM
.... S TEXT(4)=" Coding system - "_CODESYS
.... D EN^DDIOL(.TEXT)
.... S IMP=$$ASKYN^PXRMEUT("Y","Import","","")
... I IMP S SAVELIST(TIEN,TERM,CODESYS)=""
S SAVED=0,TIEN=""
F S TIEN=$O(SAVELIST(TIEN)) Q:TIEN="" D
. K ^TMP("PXRMCODES",$J)
. S TERM=""
. F S TERM=$O(SAVELIST(TIEN,TERM)) Q:TERM="" D
.. S CODESYS=""
.. F S CODESYS=$O(SAVELIST(TIEN,TERM,CODESYS)) Q:CODESYS="" D
... M ^TMP("PXRMCODES",$J,TERM,CODESYS)=^PXD(811.2,TIEN,20,"ATCC",TERM,CODESYS)
. S SAVEOK=$$SAVETC(IEN)
. I SAVEOK D POSTSAVE^PXRMTXSM(IEN) S SAVED=1
K ^TMP("PXRMCODES",$J)
Q SAVED
;
;==========================================
ISCSV(LINE) ;Verify that LINE is in CSV format with a least 3 pieces of
;data.
I $L(LINE)=0 Q 0
N ISCSV
S ISCSV=$S($L(LINE,",")>2:1,1:0)
I 'ISCSV D
. N TEXT
. S TEXT(1)=""
. S TEXT(2)="The following line is not in CSV format and cannot be processed:"
. S TEXT(3)=" "_LINE
. D EN^DDIOL(.TEXT)
. H 1
Q ISCSV
;
;==========================================
LEXCHK(CODE,CODESYS,TERM,NCODES,NL,TEXTOUT) ;Use $$TAX^LEX10CS
;to determine if code is a partial code that expands to a list of
;codes. Add valid codes to the list.
N ACODE,CODEI,IND,NFOUND,RESULT,SRC,TEXT
K ^TMP("LEXTAX",$J)
;DBIA #5681
S RESULT=$$TAX^LEX10CS(CODE,CODESYS,DT,"LEXTAX",0)
S NFOUND=+RESULT
I NFOUND=-1 D Q
. S TEXT(1)="Invalid coding system code pair:"
. S TEXT(2)=" Coding system is "_CODESYS_", code is "_CODE
. D EN^DDIOL(.TEXT)
. S NL=NL+1,TEXTOUT(NL)=TEXT(1)
. S NL=NL+1,TEXTOUT(NL)=TEXT(2)
. K ^TMP("LEXTAX",$J)
S SRC=+$O(^TMP("LEXTAX",$J,0))
S CODEI=""
F S CODEI=$O(^TMP("LEXTAX",$J,SRC,CODEI)) Q:CODEI="" D
. S IND=0
. F S IND=$O(^TMP("LEXTAX",$J,SRC,CODEI,IND)) Q:IND="" D
.. S ACODE=$P(^TMP("LEXTAX",$J,SRC,CODEI,IND,0),U,1)
.. S NCODES=NCODES+1
.. S NL=NL+1,TEXTOUT(NL)=$J(NCODES,5)_". "_ACODE
.. S ^TMP($J,"CODES",TERM,CODESYS,ACODE)=""
.. I '$D(^TMP($J,"CC",ACODE,CODESYS,TERM)) D
... S ^TMP($J,"CC",ACODE,CODESYS,TERM)=""
... S ^TMP($J,"CC",ACODE)=$G(^TMP($J,"CC",ACODE))+1
... S NCODES(CODESYS)=NCODES(CODESYS)+1
K ^TMP("LEXTAX",$J)
Q
;
;==========================================
LOADHF(NODEOUT) ;Load the CSV host file into ^TMP.
;The name of the host file should have a ".CSV" extension.
N FILE,GBL,LHF,PATH,TEMP
S TEMP=$$GETEHF^PXRMEXHF("CSV")
I TEMP="" Q 0
S PATH=$P(TEMP,U,1),FILE=$P(TEMP,U,2)
;Load the host file into ^TMP.
K ^TMP($J,"HFCSV")
S GBL="^TMP($J,""HFCSV"",1)"
S GBL=$NA(@GBL)
;Load the file contents into ^TMP.
S LHF=$$FTG^%ZISH(PATH,FILE,GBL,3)
I LHF=0 D EN^DDIOL("The host file load failed") H 2 K ^TMP($J,"HFCSV") Q 0
D RBLCKHF("HFCSV",NODEOUT)
K ^TMP($J,"HFCSV")
Q 1
;
;==========================================
LOADWEB(NODEOUT) ;Load the CSV file from a web site into ^TMP
N DIR,HDR,IND,JND,NL1,NL2,RESULT,TEXT,URL,X,Y
S DIR(0)="F^10:245"
S DIR("A")="Input the URL for the CSV file"
D ^DIR
I (Y="")!(Y=U) Q 0
S URL=Y
S Y=$$LOW^XLFSTR(Y)
I $E(Y,1,5)="https" D Q 0
. D EN^DDIOL("The https protocol is not supported.")
;Load the file contents into ^TMP.
K ^TMP($J,NODEOUT),^TMP($J,"WEBCSV")
;DBIA #5553
S RESULT=$$GETURL^XTHC10(URL,10,"^TMP($J,""WEBCSV"")",.HDR)
I $P(RESULT,U,1)'=200 D Q 0
. S TEXT="Could not load the csv file: "
. S TEXT=TEXT_"Error "_$P(RESULT,U,1)_" "_$P(RESULT,U,2)
. D EN^DDIOL(.TEXT) H 2
. K ^TMP($J,"WEBCSV")
D RBLCKWEB("WEBCSV",NODEOUT)
K ^TMP($J,"WEBCSV")
Q 1
;
;==========================================
PASTECSV(NODE) ;Paste the CSV file.
N DONE,NL,TEMP
K ^TMP($J,NODE)
S DONE=0,NL=0
D EN^DDIOL("Paste the CSV file now, press <ENTER> to finish.")
D EN^DDIOL("","","!") H 1
F Q:DONE D
. R TEMP:10
. I '$T S DONE=1 Q
. I $L(TEMP)=0 S DONE=1 Q
. S NL=NL+1,^TMP($J,NODE,NL,1)=TEMP
Q
;
;==========================================
PERCHK(CODE,CODESYS,TERM,NCODES,NL,TEXTOUT) ;Use $$PERIOD^LEXU
;to verify a code is valid and add valid codes to the list.
N PDATA,RESULT
;DBIA #5679
S RESULT=$$PERIOD^LEXU(CODE,CODESYS,.PDATA)
I +RESULT=-1 Q RESULT
S NCODES=NCODES+1
S NL=NL+1,TEXTOUT(NL)=$J(NCODES,5)_". "_CODE
S ^TMP($J,"CODES",TERM,CODESYS,CODE)=""
I '$D(^TMP($J,"CC",CODE,CODESYS,TERM)) D
. S ^TMP($J,"CC",CODE,CODESYS,TERM)=""
. S ^TMP($J,"CC",CODE)=$G(^TMP($J,"CC",CODE))+1
. S NCODES(CODESYS)=NCODES(CODESYS)+1
Q RESULT
;
;==========================================
RBLCKHF(NODEIN,NODEOUT) ;FTG^%ZISH breaks lines at 255 characters. This could
;put a code across two lines. Format the ^TMP array so this does not
;happen.
N CHAR,IND,JND,KND,L1,NL1,NL2,TEMP
K ^TMP($J,"NODEOUT")
S IND="",NL1=0
F S IND=+$O(^TMP($J,NODEIN,IND)) Q:IND=0 D
. S TEMP=^TMP($J,NODEIN,IND),NL1=NL1+1
. I '$D(^TMP($J,NODEIN,IND,"OVF")) S ^TMP($J,NODEOUT,NL1,1)=TEMP Q
. S L1="",NL2=0
. F JND=1:1:$L(TEMP) D
.. S CHAR=$E(TEMP,JND)
.. S L1=L1_CHAR
.. I $L(L1)>230,CHAR="," S NL2=NL2+1,^TMP($J,NODEOUT,NL1,NL2)=L1,L1=""
.;Check for overflow nodes.
. S JND=0
. F S JND=+$O(^TMP($J,NODEIN,IND,"OVF",JND)) Q:JND=0 D
.. S TEMP=^TMP($J,NODEIN,IND,"OVF",JND)
.. F KND=1:1:$L(TEMP) D
... S CHAR=$E(TEMP,KND)
... S L1=L1_CHAR
... I $L(L1)>230,CHAR="," S NL2=NL2+1,^TMP($J,NODEOUT,NL1,NL2)=L1,L1=""
. I $L(L1)>0 S NL2=NL2+1,^TMP($J,NODEOUT,NL1,NL2)=L1
Q
;
;==========================================
RBLCKWEB(NODEIN,NODEOUT) ;GETURL^XTHC10 breaks lines at 245 characters. This
;could break a line into two lines. Format the ^TMP array so this does
;not happen.
N CHAR,IND,JND,KND,L1,LEN,NL1,NL2,TEMP
K ^TMP($J,"NODEOUT")
S IND="",NL1=0
F S IND=+$O(^TMP($J,NODEIN,IND)) Q:IND=0 D
. S TEMP=^TMP($J,NODEIN,IND),LEN=$L(TEMP)
. I LEN=0 S NL1=NL1+1,^TMP($J,NODEOUT,NL1,1)=TEMP Q
. S NL1=NL1+1
. I $D(^TMP($J,NODEIN,IND))<11 S ^TMP($J,NODEOUT,NL1,1)=$TR(TEMP,$C(13),"") Q
. S L1="",NL2=0
. F JND=1:1:$L(TEMP) D
.. S CHAR=$E(TEMP,JND)
.. I CHAR=$C(13) Q
.. S L1=L1_CHAR
.. I $L(L1)>230,CHAR="," S NL2=NL2+1,^TMP($J,NODEOUT,NL1,NL2)=L1,L1=""
.;Check for overflow nodes.
. S JND=0
. F S JND=+$O(^TMP($J,NODEIN,IND,JND)) Q:JND=0 D
.. S TEMP=^TMP($J,NODEIN,IND,JND)
.. F KND=1:1:$L(TEMP) D
... S CHAR=$E(TEMP,KND)
... I CHAR=$C(13) Q
... S L1=L1_CHAR
... I $L(L1)>230,CHAR="," S NL2=NL2+1,^TMP($J,NODEOUT,NL1,NL2)=L1,L1=""
. I $L(L1)>0 S NL2=NL2+1,^TMP($J,NODEOUT,NL1,NL2)=L1
Q
;
;==========================================
SAVETC(IEN) ;Save the term/code.
N FDA,IENS,IND,MSG,SUCCESS,TC
S IND=0,SUCCESS=1,TC=""
F S TC=$O(^TMP("PXRMCODES",$J,TC)) Q:TC="" D
.;If the Term/Code already exists skip it.
. I $D(^PXD(811.2,IEN,20,"B",TC)) Q
. S IND=IND+1
. S IENS="+"_IND_","_IEN_","
. S FDA(811.23,IENS,.01)=TC
I '$D(FDA(811.23)) Q SUCCESS
D UPDATE^DIE("","FDA","","MSG")
I $D(MSG) D
. D FULL^VALM1
. D MES^XPDUTL("Unable to store Term/Code "_TC)
. D AWRITE^PXRMUTIL("MSG") H 1
. S SUCCESS=0
Q SUCCESS
;
;==========================================
UPDCL(IEN,TEXT) ;Add an entry to the change log.
N IENS,FDA,FDAIEN,MSG,WPTMP
S IENS="+1,"_IEN_","
S FDA(811.21,IENS,.01)=$$NOW^XLFDT
S FDA(811.21,IENS,1)=DUZ
S WPTMP(1,1,1)=" Import codes "_TEXT_"."
S FDA(811.21,IENS,2)="WPTMP(1,1)"
D UPDATE^DIE("S","FDA","FDAIEN","MSG")
K DA,DDSFILE
S DA=FDAIEN(1),DA(1)=IEN
S DDSFILE=811.2,DDSFILE(1)=811.21
S DR="[PXRM TAXONOMY CHANGE LOG]"
D ^DDS
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMTXIM 16188 printed Oct 16, 2024@17:50:26 Page 2
PXRMTXIM ;SLC/PKR - Taxonomy import/create routines. ;02/19/2015
+1 ;;2.0;CLINICAL REMINDERS;**26,47**;Feb 04, 2005;Build 291
+2 ;==========================================
CRETAX(FLAGS,TXDATA,ERRMSG) ;Create a taxonomy based on the data in TXDATA.
+1 ;The following TXDATA nodes are required:
+2 ;NAME, CLASS, and SOURCE.
+3 ;The SPONSOR node is optional, it is a pointer to the Sponsor file.
+4 ;Codes to include in the taxonomy are specified as
+5 ;TXDATA("CODE",CODESYS,CODEP)=FMT^UID
+6 ;where CODESYS is one of the following: 10D, 10P, CPT, ICD, ICP, SCT.
+7 ;CODEP is either the code or its IEN, except for SCT where it must be
+8 ;the code. FMT is "E" if CODEP is the code and "I" if it is the
+9 ;pointer. UID is 1 if the code can be used in a dialog and 0 or null
+10 ;if it cannot.
+11 NEW CDATA,CODE,CODEP,CODESYS,CODESYST,DESC,IENS,FDA,FDAIEN,FMT,MSG
+12 NEW RESULT,SAVEOK,TC,TEMP,UID
+13 IF $DATA(TXDATA("DESC"))
MERGE DESC=TXDATA("DESC")
+14 IF '$TEST
SET DESC(1,0)="This taxonomy was automatically generated from "_TXDATA("SOURCE")_"."
+15 SET IENS="+1,"
+16 SET FDA(811.2,IENS,.01)=TXDATA("NAME")
+17 SET FDA(811.2,IENS,2)="DESC"
+18 IF $DATA(TXDATA("OID"))
SET FDA(811.2,IENS,40)=TXDATA("OID")
+19 IF $DATA(TXDATA("VERSION DATE"))
SET FDA(811.2,IENS,41)=TXDATA("VERSION DATE")
+20 SET FDA(811.2,IENS,100)=TXDATA("CLASS")
+21 IF $DATA(TXDATA("SPONSOR"))
SET FDA(811.2,IENS,101)=TXDATA("SPONSOR")
+22 DO UPDATE^DIE(FLAGS,"FDA","FDAIEN","MSG")
+23 IF $DATA(MSG)
Begin DoDot:1
+24 NEW IC,EMSG,REF
+25 SET REF="MSG"
+26 FOR IC=1:1
SET REF=$QUERY(@REF)
if REF=""
QUIT
SET EMSG(IC)=REF_"="_@REF
+27 DO BMES^XPDUTL("Could not create taxonomy named "_TXDATA("NAME"))
+28 DO MES^XPDUTL(.EMSG)
End DoDot:1
QUIT 0
+29 KILL ^TMP("PXRMCODES",$JOB)
+30 SET CODESYST=""
+31 FOR
SET CODESYST=$ORDER(TXDATA("CODE",CODESYST))
if CODESYST=""
QUIT
Begin DoDot:1
+32 SET CODEP=""
+33 FOR
SET CODEP=$ORDER(TXDATA("CODE",CODESYST,CODEP))
if CODEP=""
QUIT
Begin DoDot:2
+34 SET CODESYS=CODESYST
+35 SET TEMP=$GET(TXDATA("CODE",CODESYST,CODEP))
+36 SET FMT=$PIECE(TEMP,U,1)
+37 SET UID=+$PIECE(TEMP,U,2)
+38 ;DBIA #5747
+39 IF (CODESYST="10D")!(CODESYS="ICD")
SET RESULT=$$ICDDX^ICDEX(CODEP,DT,CODESYS,FMT)
+40 IF (CODESYST="10P")!(CODESYS="ICP")
SET RESULT=$$ICDOP^ICDEX(CODEP,DT,CODESYS,FMT)
+41 ;DBIA #1995
+42 IF CODESYST="CPC"
SET RESULT=$$CPT^ICPTCOD(CODEP)
+43 IF CODESYST="CPT"
SET RESULT=$$CPT^ICPTCOD(CODEP)
IF $PIECE(RESULT,U,5)="H"
SET CODESYS="CPC"
+44 IF CODESYST="SCT"
SET RESULT=1_U_CODEP
+45 IF +RESULT=-1
SET ERRMSG(CODESYS,CODEP)=$PIECE(RESULT,U,2)
QUIT
+46 SET CODE=$PIECE(RESULT,U,2)
+47 KILL CDATA
+48 ;DBIA #5679
+49 SET RESULT=$$CSDATA^LEXU(CODE,CODESYS,DT,.CDATA)
+50 SET TC=$PIECE(CDATA("LEX",1),U,2)
+51 IF TC=""
SET TC=CDATA("SYS",14,1)
+52 IF TC=""
SET ERRMSG(CODESYS,CODE)="No description found."
QUIT
+53 SET ^TMP("PXRMCODES",$JOB,TC,CODESYS,CODE)=UID
End DoDot:2
End DoDot:1
+54 SET SAVEOK=$$SAVETC^PXRMTXIM(FDAIEN(1))
+55 IF SAVEOK
DO POSTSAVE^PXRMTXSM(FDAIEN(1))
+56 QUIT FDAIEN(1)
+57 ;
+58 ;==========================================
IMP(IEN) ;Import codes into a taxonomy.
+1 NEW CLASS,DIR,LOADOK,NATOK,OPTION,PXRMTIEN,SAVED,X,Y
+2 SET CLASS=$PIECE(^PXD(811.2,IEN,100),U,1)
+3 SET NATOK=$SELECT(CLASS'="N":1,1:($GET(PXRMINST)=1)&($GET(DUZ(0))="@"))
+4 IF 'NATOK
Begin DoDot:1
+5 DO EN^DDIOL("Codes cannot be imported into national taxonomies!")
+6 HANG 2
+7 SET VALMBCK="R"
End DoDot:1
QUIT
+8 ;Present the menu of import choices.
+9 SET DIR(0)="S^HF:CSV host file;"
+10 SET DIR(0)=DIR(0)_"PA:CSV file paste;"
+11 SET DIR(0)=DIR(0)_"TAX:Another taxonomy;"
+12 SET DIR(0)=DIR(0)_"WEB:CSV file from a web site"
+13 SET DIR("A")="Select the import method"
+14 SET DIR("??")="^D HELP^PXRMTXIH"
+15 DO ^DIR
+16 SET OPTION=Y
+17 IF OPTION="HF"
Begin DoDot:1
+18 SET LOADOK=$$LOADHF("TAXIMP")
+19 IF LOADOK
Begin DoDot:2
+20 SET SAVED=$$IMPCSV(IEN,"TAXIMP")
+21 IF SAVED
DO UPDCL(IEN,"from a host file")
End DoDot:2
End DoDot:1
+22 IF OPTION="PA"
Begin DoDot:1
+23 DO PASTECSV("TAXIMP")
+24 SET SAVED=$$IMPCSV(IEN,"TAXIMP")
+25 IF SAVED
DO UPDCL(IEN,"by pasting")
End DoDot:1
+26 IF OPTION="TAX"
Begin DoDot:1
+27 DO START^PXRMTXCE
+28 SET SAVED=$$IMPTAX(IEN,.PXRMTIEN)
+29 IF SAVED
DO UPDCL(IEN,"from other taxonomies")
End DoDot:1
+30 IF OPTION="WEB"
Begin DoDot:1
+31 SET LOADOK=$$LOADWEB("TAXIMP")
+32 IF LOADOK
Begin DoDot:2
+33 SET SAVED=$$IMPCSV(IEN,"TAXIMP")
+34 IF SAVED
DO UPDCL(IEN,"from a web site")
End DoDot:2
End DoDot:1
+35 SET VALMBCK="R"
+36 QUIT
+37 ;
+38 ;==========================================
IMPCSV(IEN,NODE) ;Import comma separated data into the Lexicon Term/Code
+1 ;multiple. The expected format is:
+2 ;LEXICON TERM/CODE,CODING SYSTEM,CODE 1,CODE 2, .... CODE N.
+3 IF '$DATA(^TMP($JOB,NODE))
QUIT 0
+4 NEW ANS,CODE,CODESYS,CODESYSN,DUPL,IND,JND,KND,NCODES,NL,RESULT
+5 NEW SAVED,SAVEOK,TEMP,TERM,TEXT,TEXTOUT
+6 KILL ^TMP($JOB,"CC")
+7 SET (IND,NL,SAVED)=0
+8 DO EN^DDIOL("Starting the import process ... ")
+9 FOR
SET IND=$ORDER(^TMP($JOB,NODE,IND))
if IND=""
QUIT
Begin DoDot:1
+10 SET TEMP=^TMP($JOB,NODE,IND,1)
+11 IF '$$ISCSV(TEMP)
QUIT
+12 SET TERM=$PIECE(TEMP,",",1)
+13 IF (TERM="")!(TERM="^")
QUIT
+14 SET TERM=TERM_" (imported)"
+15 IF IND>1
SET NL=NL+1
SET TEXTOUT(NL)=""
+16 SET NL=NL+1
SET TEXTOUT(NL)="Term/Code: "_TERM
+17 SET CODESYS=$PIECE(TEMP,",",2)
+18 ;DBIA #5679
+19 IF '$DATA(CODESYSN(CODESYS))
SET CODESYSN(CODESYS)=$PIECE($$CSYS^LEXU(CODESYS),U,4)
+20 ;Make sure it is a valid Lexicon coding system.
+21 ;DBIA #5679
+22 SET RESULT=$$CSYS^LEXU(CODESYS)
+23 IF +RESULT=-1
Begin DoDot:2
+24 SET TEXT=" Coding System: "_CODESYS_" not found in Lexicon."
+25 DO EN^DDIOL(TEXT)
End DoDot:2
+26 IF +RESULT'=-1
Begin DoDot:2
+27 SET TEXT=" Coding System: "_$PIECE(RESULT,U,4)
+28 IF '$DATA(NCODES(CODESYS))
SET NCODES(CODESYS)=0
End DoDot:2
+29 SET NL=NL+1
SET TEXTOUT(NL)=TEXT
+30 IF +RESULT=-1
QUIT
+31 ;Make sure it is a valid taxonomy coding system.
+32 IF '$$VCODESYS^PXRMLEX(CODESYS)
SET NL=NL+1
SET TEXTOUT(NL)=" Warning taxonomies do not use "_CODESYS_" codes."
QUIT
+33 SET NCODES=0
+34 FOR JND=3:1:$LENGTH(TEMP,",")
Begin DoDot:2
+35 SET CODE=$PIECE(TEMP,",",JND)
+36 SET CODE=$TRANSLATE(CODE," ","")
+37 IF CODE=""
QUIT
+38 SET RESULT=$$PERCHK(CODE,CODESYS,TERM,.NCODES,.NL,.TEXTOUT)
+39 IF +RESULT=-1
DO LEXCHK(CODE,CODESYS,TERM,.NCODES,.NL,.TEXTOUT)
End DoDot:2
+40 ;Check for additional code only nodes in ^TMP.
+41 SET JND=1
+42 FOR
SET JND=$ORDER(^TMP($JOB,NODE,IND,JND))
if JND=""
QUIT
Begin DoDot:2
+43 SET TEMP=^TMP($JOB,NODE,IND,JND)
+44 FOR KND=1:1:$LENGTH(TEMP,",")
Begin DoDot:3
+45 SET CODE=$PIECE(TEMP,",",KND)
+46 SET CODE=$TRANSLATE(CODE," ","")
+47 IF CODE=""
QUIT
+48 SET RESULT=$$PERCHK(CODE,CODESYS,TERM,.NCODES,.NL,.TEXTOUT)
+49 IF +RESULT=-1
DO LEXCHK(CODE,CODESYS,TERM,.NCODES,.NL,.TEXTOUT)
End DoDot:3
End DoDot:2
End DoDot:1
+50 SET NL=NL+1
SET TEXTOUT(NL)=""
+51 ;Look for duplicate codes.
+52 SET CODE=""
+53 FOR
SET CODE=$ORDER(^TMP($JOB,"CC",CODE))
if CODE=""
QUIT
Begin DoDot:1
+54 IF ^TMP($JOB,"CC",CODE)>1
SET DUPL(CODE)=^TMP($JOB,"CC",CODE)
End DoDot:1
+55 IF $DATA(DUPL)
DO EN^DDIOL("This import contains duplicate codes.")
+56 IF '$DATA(NCODES)
Begin DoDot:1
+57 DO EN^DDIOL("There are no codes to import.")
+58 SET VALMBCK="R"
+59 HANG 2
End DoDot:1
QUIT SAVED
+60 ;
+61 SET ANS=$$ASKYN^PXRMEUT("Y","Do you want to browse the list of codes")
+62 IF ANS
Begin DoDot:1
+63 SET NL=NL+1
SET TEXTOUT(NL)=""
+64 SET NL=NL+1
SET TEXTOUT(NL)="This import includes the following numbers of codes:"
+65 SET CODESYS=""
SET TEMP=0
+66 FOR
SET CODESYS=$ORDER(NCODES(CODESYS))
if CODESYS=""
QUIT
Begin DoDot:2
+67 SET NL=NL+1
SET TEXTOUT(NL)=CODESYSN(CODESYS)_": "_NCODES(CODESYS)
+68 SET TEMP=TEMP+NCODES(CODESYS)
End DoDot:2
+69 SET NL=NL+1
SET TEXTOUT(NL)="Total number of codes: "_TEMP
+70 ;If there are duplicates, list them.
+71 IF $DATA(DUPL)
Begin DoDot:2
+72 SET NL=NL+1
SET TEXTOUT(NL)=""
+73 SET NL=NL+1
SET TEXTOUT(NL)="The following codes are included in more than one Term/Code:"
+74 SET CODE=""
+75 FOR
SET CODE=$ORDER(DUPL(CODE))
if CODE=""
QUIT
Begin DoDot:3
+76 SET CODESYS=""
+77 FOR
SET CODESYS=$ORDER(^TMP($JOB,"CC",CODE,CODESYS))
if CODESYS=""
QUIT
Begin DoDot:4
+78 SET NL=NL+1
SET TEXTOUT(NL)=CODESYSN(CODESYS)_" code "_CODE_" is included "_DUPL(CODE)_" times."
+79 SET NL=NL+1
SET TEXTOUT(NL)=" Term/Code:"
+80 SET TERM=""
+81 FOR
SET TERM=$ORDER(^TMP($JOB,"CC",CODE,CODESYS,TERM))
if TERM=""
QUIT
Begin DoDot:5
+82 SET NL=NL+1
SET TEXTOUT(NL)=" "_TERM
End DoDot:5
End DoDot:4
+83 SET NL=NL+1
SET TEXTOUT(NL)=""
End DoDot:3
+84 SET NL=NL+1
SET TEXTOUT(NL)="After importing the codes more details can be found in the taxonomy inquiry."
End DoDot:2
+85 DO BROWSE^DDBR("TEXTOUT","NR","List Of Codes To Be Imported")
End DoDot:1
+86 SET SAVED=0
+87 SET ANS=$$ASKYN^PXRMEUT("Y","Do you want to save the imported codes")
+88 IF ANS
Begin DoDot:1
+89 MERGE ^TMP("PXRMCODES",$JOB)=^TMP($JOB,"CODES")
+90 SET SAVEOK=$$SAVETC(IEN)
+91 IF SAVEOK
DO POSTSAVE^PXRMTXSM(IEN)
SET SAVED=1
End DoDot:1
+92 ;
+93 KILL ^TMP($JOB,NODE),^TMP($JOB,"CC"),^TMP($JOB,"CODES")
+94 SET VALMBCK="R"
+95 QUIT SAVED
+96 ;
+97 ;==========================================
IMPTAX(IEN,PXRMTIEN) ;Import codes from other taxonomies.
+1 ;Go through the list ask if some or all, if some then have to prompt
+2 ;for each term/code.
+3 NEW ANS,CODESYS,DIR,IMP,IND,JND,SAVED,SAVELIST,SAVEOK
+4 NEW TIEN,TERM,TEXT,TNAME,X,Y
+5 SET DIR(0)="S^ALL:All codes;"
+6 SET DIR(0)=DIR(0)_"SEL:Selected codes"
+7 SET DIR("B")="ALL"
+8 SET TIEN=0
+9 FOR
SET TIEN=$ORDER(PXRMTIEN(TIEN))
if TIEN=""
QUIT
Begin DoDot:1
+10 SET TNAME=$PIECE(^PXD(811.2,TIEN,0),U,1)
+11 DO EN^DDIOL("Ready to import codes from taxonomy "_TNAME)
+12 DO ^DIR
+13 SET ANS=Y
+14 SET IND=0
+15 FOR
SET IND=+$ORDER(^PXD(811.2,TIEN,20,IND))
if IND=0
QUIT
Begin DoDot:2
+16 SET TERM=^PXD(811.2,TIEN,20,IND,0)
+17 SET JND=0
+18 FOR
SET JND=+$ORDER(^PXD(811.2,TIEN,20,IND,1,JND))
if JND=0
QUIT
Begin DoDot:3
+19 SET CODESYS=$PIECE(^PXD(811.2,TIEN,20,IND,1,JND,0),U,1)
+20 SET IMP=$SELECT(ANS="SEL":0,1:1)
+21 IF ANS="SEL"
Begin DoDot:4
+22 SET TEXT(1)=""
+23 SET TEXT(2)="Import codes from:"
+24 SET TEXT(3)=" Term/Code - "_TERM
+25 SET TEXT(4)=" Coding system - "_CODESYS
+26 DO EN^DDIOL(.TEXT)
+27 SET IMP=$$ASKYN^PXRMEUT("Y","Import","","")
End DoDot:4
+28 IF IMP
SET SAVELIST(TIEN,TERM,CODESYS)=""
End DoDot:3
End DoDot:2
End DoDot:1
+29 SET SAVED=0
SET TIEN=""
+30 FOR
SET TIEN=$ORDER(SAVELIST(TIEN))
if TIEN=""
QUIT
Begin DoDot:1
+31 KILL ^TMP("PXRMCODES",$JOB)
+32 SET TERM=""
+33 FOR
SET TERM=$ORDER(SAVELIST(TIEN,TERM))
if TERM=""
QUIT
Begin DoDot:2
+34 SET CODESYS=""
+35 FOR
SET CODESYS=$ORDER(SAVELIST(TIEN,TERM,CODESYS))
if CODESYS=""
QUIT
Begin DoDot:3
+36 MERGE ^TMP("PXRMCODES",$JOB,TERM,CODESYS)=^PXD(811.2,TIEN,20,"ATCC",TERM,CODESYS)
End DoDot:3
End DoDot:2
+37 SET SAVEOK=$$SAVETC(IEN)
+38 IF SAVEOK
DO POSTSAVE^PXRMTXSM(IEN)
SET SAVED=1
End DoDot:1
+39 KILL ^TMP("PXRMCODES",$JOB)
+40 QUIT SAVED
+41 ;
+42 ;==========================================
ISCSV(LINE) ;Verify that LINE is in CSV format with a least 3 pieces of
+1 ;data.
+2 IF $LENGTH(LINE)=0
QUIT 0
+3 NEW ISCSV
+4 SET ISCSV=$SELECT($LENGTH(LINE,",")>2:1,1:0)
+5 IF 'ISCSV
Begin DoDot:1
+6 NEW TEXT
+7 SET TEXT(1)=""
+8 SET TEXT(2)="The following line is not in CSV format and cannot be processed:"
+9 SET TEXT(3)=" "_LINE
+10 DO EN^DDIOL(.TEXT)
+11 HANG 1
End DoDot:1
+12 QUIT ISCSV
+13 ;
+14 ;==========================================
LEXCHK(CODE,CODESYS,TERM,NCODES,NL,TEXTOUT) ;Use $$TAX^LEX10CS
+1 ;to determine if code is a partial code that expands to a list of
+2 ;codes. Add valid codes to the list.
+3 NEW ACODE,CODEI,IND,NFOUND,RESULT,SRC,TEXT
+4 KILL ^TMP("LEXTAX",$JOB)
+5 ;DBIA #5681
+6 SET RESULT=$$TAX^LEX10CS(CODE,CODESYS,DT,"LEXTAX",0)
+7 SET NFOUND=+RESULT
+8 IF NFOUND=-1
Begin DoDot:1
+9 SET TEXT(1)="Invalid coding system code pair:"
+10 SET TEXT(2)=" Coding system is "_CODESYS_", code is "_CODE
+11 DO EN^DDIOL(.TEXT)
+12 SET NL=NL+1
SET TEXTOUT(NL)=TEXT(1)
+13 SET NL=NL+1
SET TEXTOUT(NL)=TEXT(2)
+14 KILL ^TMP("LEXTAX",$JOB)
End DoDot:1
QUIT
+15 SET SRC=+$ORDER(^TMP("LEXTAX",$JOB,0))
+16 SET CODEI=""
+17 FOR
SET CODEI=$ORDER(^TMP("LEXTAX",$JOB,SRC,CODEI))
if CODEI=""
QUIT
Begin DoDot:1
+18 SET IND=0
+19 FOR
SET IND=$ORDER(^TMP("LEXTAX",$JOB,SRC,CODEI,IND))
if IND=""
QUIT
Begin DoDot:2
+20 SET ACODE=$PIECE(^TMP("LEXTAX",$JOB,SRC,CODEI,IND,0),U,1)
+21 SET NCODES=NCODES+1
+22 SET NL=NL+1
SET TEXTOUT(NL)=$JUSTIFY(NCODES,5)_". "_ACODE
+23 SET ^TMP($JOB,"CODES",TERM,CODESYS,ACODE)=""
+24 IF '$DATA(^TMP($JOB,"CC",ACODE,CODESYS,TERM))
Begin DoDot:3
+25 SET ^TMP($JOB,"CC",ACODE,CODESYS,TERM)=""
+26 SET ^TMP($JOB,"CC",ACODE)=$GET(^TMP($JOB,"CC",ACODE))+1
+27 SET NCODES(CODESYS)=NCODES(CODESYS)+1
End DoDot:3
End DoDot:2
End DoDot:1
+28 KILL ^TMP("LEXTAX",$JOB)
+29 QUIT
+30 ;
+31 ;==========================================
LOADHF(NODEOUT) ;Load the CSV host file into ^TMP.
+1 ;The name of the host file should have a ".CSV" extension.
+2 NEW FILE,GBL,LHF,PATH,TEMP
+3 SET TEMP=$$GETEHF^PXRMEXHF("CSV")
+4 IF TEMP=""
QUIT 0
+5 SET PATH=$PIECE(TEMP,U,1)
SET FILE=$PIECE(TEMP,U,2)
+6 ;Load the host file into ^TMP.
+7 KILL ^TMP($JOB,"HFCSV")
+8 SET GBL="^TMP($J,""HFCSV"",1)"
+9 SET GBL=$NAME(@GBL)
+10 ;Load the file contents into ^TMP.
+11 SET LHF=$$FTG^%ZISH(PATH,FILE,GBL,3)
+12 IF LHF=0
DO EN^DDIOL("The host file load failed")
HANG 2
KILL ^TMP($JOB,"HFCSV")
QUIT 0
+13 DO RBLCKHF("HFCSV",NODEOUT)
+14 KILL ^TMP($JOB,"HFCSV")
+15 QUIT 1
+16 ;
+17 ;==========================================
LOADWEB(NODEOUT) ;Load the CSV file from a web site into ^TMP
+1 NEW DIR,HDR,IND,JND,NL1,NL2,RESULT,TEXT,URL,X,Y
+2 SET DIR(0)="F^10:245"
+3 SET DIR("A")="Input the URL for the CSV file"
+4 DO ^DIR
+5 IF (Y="")!(Y=U)
QUIT 0
+6 SET URL=Y
+7 SET Y=$$LOW^XLFSTR(Y)
+8 IF $EXTRACT(Y,1,5)="https"
Begin DoDot:1
+9 DO EN^DDIOL("The https protocol is not supported.")
End DoDot:1
QUIT 0
+10 ;Load the file contents into ^TMP.
+11 KILL ^TMP($JOB,NODEOUT),^TMP($JOB,"WEBCSV")
+12 ;DBIA #5553
+13 SET RESULT=$$GETURL^XTHC10(URL,10,"^TMP($J,""WEBCSV"")",.HDR)
+14 IF $PIECE(RESULT,U,1)'=200
Begin DoDot:1
+15 SET TEXT="Could not load the csv file: "
+16 SET TEXT=TEXT_"Error "_$PIECE(RESULT,U,1)_" "_$PIECE(RESULT,U,2)
+17 DO EN^DDIOL(.TEXT)
HANG 2
+18 KILL ^TMP($JOB,"WEBCSV")
End DoDot:1
QUIT 0
+19 DO RBLCKWEB("WEBCSV",NODEOUT)
+20 KILL ^TMP($JOB,"WEBCSV")
+21 QUIT 1
+22 ;
+23 ;==========================================
PASTECSV(NODE) ;Paste the CSV file.
+1 NEW DONE,NL,TEMP
+2 KILL ^TMP($JOB,NODE)
+3 SET DONE=0
SET NL=0
+4 DO EN^DDIOL("Paste the CSV file now, press <ENTER> to finish.")
+5 DO EN^DDIOL("","","!")
HANG 1
+6 FOR
if DONE
QUIT
Begin DoDot:1
+7 READ TEMP:10
+8 IF '$TEST
SET DONE=1
QUIT
+9 IF $LENGTH(TEMP)=0
SET DONE=1
QUIT
+10 SET NL=NL+1
SET ^TMP($JOB,NODE,NL,1)=TEMP
End DoDot:1
+11 QUIT
+12 ;
+13 ;==========================================
PERCHK(CODE,CODESYS,TERM,NCODES,NL,TEXTOUT) ;Use $$PERIOD^LEXU
+1 ;to verify a code is valid and add valid codes to the list.
+2 NEW PDATA,RESULT
+3 ;DBIA #5679
+4 SET RESULT=$$PERIOD^LEXU(CODE,CODESYS,.PDATA)
+5 IF +RESULT=-1
QUIT RESULT
+6 SET NCODES=NCODES+1
+7 SET NL=NL+1
SET TEXTOUT(NL)=$JUSTIFY(NCODES,5)_". "_CODE
+8 SET ^TMP($JOB,"CODES",TERM,CODESYS,CODE)=""
+9 IF '$DATA(^TMP($JOB,"CC",CODE,CODESYS,TERM))
Begin DoDot:1
+10 SET ^TMP($JOB,"CC",CODE,CODESYS,TERM)=""
+11 SET ^TMP($JOB,"CC",CODE)=$GET(^TMP($JOB,"CC",CODE))+1
+12 SET NCODES(CODESYS)=NCODES(CODESYS)+1
End DoDot:1
+13 QUIT RESULT
+14 ;
+15 ;==========================================
RBLCKHF(NODEIN,NODEOUT) ;FTG^%ZISH breaks lines at 255 characters. This could
+1 ;put a code across two lines. Format the ^TMP array so this does not
+2 ;happen.
+3 NEW CHAR,IND,JND,KND,L1,NL1,NL2,TEMP
+4 KILL ^TMP($JOB,"NODEOUT")
+5 SET IND=""
SET NL1=0
+6 FOR
SET IND=+$ORDER(^TMP($JOB,NODEIN,IND))
if IND=0
QUIT
Begin DoDot:1
+7 SET TEMP=^TMP($JOB,NODEIN,IND)
SET NL1=NL1+1
+8 IF '$DATA(^TMP($JOB,NODEIN,IND,"OVF"))
SET ^TMP($JOB,NODEOUT,NL1,1)=TEMP
QUIT
+9 SET L1=""
SET NL2=0
+10 FOR JND=1:1:$LENGTH(TEMP)
Begin DoDot:2
+11 SET CHAR=$EXTRACT(TEMP,JND)
+12 SET L1=L1_CHAR
+13 IF $LENGTH(L1)>230
IF CHAR=","
SET NL2=NL2+1
SET ^TMP($JOB,NODEOUT,NL1,NL2)=L1
SET L1=""
End DoDot:2
+14 ;Check for overflow nodes.
+15 SET JND=0
+16 FOR
SET JND=+$ORDER(^TMP($JOB,NODEIN,IND,"OVF",JND))
if JND=0
QUIT
Begin DoDot:2
+17 SET TEMP=^TMP($JOB,NODEIN,IND,"OVF",JND)
+18 FOR KND=1:1:$LENGTH(TEMP)
Begin DoDot:3
+19 SET CHAR=$EXTRACT(TEMP,KND)
+20 SET L1=L1_CHAR
+21 IF $LENGTH(L1)>230
IF CHAR=","
SET NL2=NL2+1
SET ^TMP($JOB,NODEOUT,NL1,NL2)=L1
SET L1=""
End DoDot:3
End DoDot:2
+22 IF $LENGTH(L1)>0
SET NL2=NL2+1
SET ^TMP($JOB,NODEOUT,NL1,NL2)=L1
End DoDot:1
+23 QUIT
+24 ;
+25 ;==========================================
RBLCKWEB(NODEIN,NODEOUT) ;GETURL^XTHC10 breaks lines at 245 characters. This
+1 ;could break a line into two lines. Format the ^TMP array so this does
+2 ;not happen.
+3 NEW CHAR,IND,JND,KND,L1,LEN,NL1,NL2,TEMP
+4 KILL ^TMP($JOB,"NODEOUT")
+5 SET IND=""
SET NL1=0
+6 FOR
SET IND=+$ORDER(^TMP($JOB,NODEIN,IND))
if IND=0
QUIT
Begin DoDot:1
+7 SET TEMP=^TMP($JOB,NODEIN,IND)
SET LEN=$LENGTH(TEMP)
+8 IF LEN=0
SET NL1=NL1+1
SET ^TMP($JOB,NODEOUT,NL1,1)=TEMP
QUIT
+9 SET NL1=NL1+1
+10 IF $DATA(^TMP($JOB,NODEIN,IND))<11
SET ^TMP($JOB,NODEOUT,NL1,1)=$TRANSLATE(TEMP,$CHAR(13),"")
QUIT
+11 SET L1=""
SET NL2=0
+12 FOR JND=1:1:$LENGTH(TEMP)
Begin DoDot:2
+13 SET CHAR=$EXTRACT(TEMP,JND)
+14 IF CHAR=$CHAR(13)
QUIT
+15 SET L1=L1_CHAR
+16 IF $LENGTH(L1)>230
IF CHAR=","
SET NL2=NL2+1
SET ^TMP($JOB,NODEOUT,NL1,NL2)=L1
SET L1=""
End DoDot:2
+17 ;Check for overflow nodes.
+18 SET JND=0
+19 FOR
SET JND=+$ORDER(^TMP($JOB,NODEIN,IND,JND))
if JND=0
QUIT
Begin DoDot:2
+20 SET TEMP=^TMP($JOB,NODEIN,IND,JND)
+21 FOR KND=1:1:$LENGTH(TEMP)
Begin DoDot:3
+22 SET CHAR=$EXTRACT(TEMP,KND)
+23 IF CHAR=$CHAR(13)
QUIT
+24 SET L1=L1_CHAR
+25 IF $LENGTH(L1)>230
IF CHAR=","
SET NL2=NL2+1
SET ^TMP($JOB,NODEOUT,NL1,NL2)=L1
SET L1=""
End DoDot:3
End DoDot:2
+26 IF $LENGTH(L1)>0
SET NL2=NL2+1
SET ^TMP($JOB,NODEOUT,NL1,NL2)=L1
End DoDot:1
+27 QUIT
+28 ;
+29 ;==========================================
SAVETC(IEN) ;Save the term/code.
+1 NEW FDA,IENS,IND,MSG,SUCCESS,TC
+2 SET IND=0
SET SUCCESS=1
SET TC=""
+3 FOR
SET TC=$ORDER(^TMP("PXRMCODES",$JOB,TC))
if TC=""
QUIT
Begin DoDot:1
+4 ;If the Term/Code already exists skip it.
+5 IF $DATA(^PXD(811.2,IEN,20,"B",TC))
QUIT
+6 SET IND=IND+1
+7 SET IENS="+"_IND_","_IEN_","
+8 SET FDA(811.23,IENS,.01)=TC
End DoDot:1
+9 IF '$DATA(FDA(811.23))
QUIT SUCCESS
+10 DO UPDATE^DIE("","FDA","","MSG")
+11 IF $DATA(MSG)
Begin DoDot:1
+12 DO FULL^VALM1
+13 DO MES^XPDUTL("Unable to store Term/Code "_TC)
+14 DO AWRITE^PXRMUTIL("MSG")
HANG 1
+15 SET SUCCESS=0
End DoDot:1
+16 QUIT SUCCESS
+17 ;
+18 ;==========================================
UPDCL(IEN,TEXT) ;Add an entry to the change log.
+1 NEW IENS,FDA,FDAIEN,MSG,WPTMP
+2 SET IENS="+1,"_IEN_","
+3 SET FDA(811.21,IENS,.01)=$$NOW^XLFDT
+4 SET FDA(811.21,IENS,1)=DUZ
+5 SET WPTMP(1,1,1)=" Import codes "_TEXT_"."
+6 SET FDA(811.21,IENS,2)="WPTMP(1,1)"
+7 DO UPDATE^DIE("S","FDA","FDAIEN","MSG")
+8 KILL DA,DDSFILE
+9 SET DA=FDAIEN(1)
SET DA(1)=IEN
+10 SET DDSFILE=811.2
SET DDSFILE(1)=811.21
+11 SET DR="[PXRM TAXONOMY CHANGE LOG]"
+12 DO ^DDS
+13 QUIT
+14 ;
