PXRMTXCR ;SLC/PKR - Taxonomies, copy from a range. ;05/07/2014
;;2.0;CLINICAL REMINDERS;**26**;Feb 04, 2005;Build 404
;==========================================
BLDCFR(IEN,NODE) ;Build the range, selectable diagnosis, and selectable
;procedure lists.
N CODE,CODEIEN,CODESYS,HIGH,IND,LOW,TNODE,TEMP
K ^TMP($J,NODE)
F CODESYS="ICD","ICP","CPT" D
. S TNODE=$S(CODESYS="ICD":80,CODESYS="ICP":80.1,CODESYS="CPT":81)
. S IND=0
. F S IND=+$O(^PXD(811.2,IEN,TNODE,IND)) Q:IND=0 D
.. S TEMP=^PXD(811.2,IEN,TNODE,IND,0)
.. S LOW=$P(TEMP,U,1),HIGH=$P(TEMP,U,2)
.. I HIGH="" S HIGH=LOW
.. S ^TMP($J,NODE,CODESYS,LOW,HIGH)=""
;
S IND=0
F S IND=+$O(^PXD(811.2,IEN,"SDX",IND)) Q:IND=0 D
. S CODEIEN=$P(^PXD(811.2,IEN,"SDX",IND,0),U,1)
.;DBIA #5747
. S TEMP=$$ICDDX^ICDEX(CODEIEN,DT,"ICD","I")
. S CODE=$P(TEMP,U,2)
. S ^TMP($J,NODE,"SDX",CODE)=TEMP
S IND=0
F S IND=+$O(^PXD(811.2,IEN,"SPR",IND)) Q:IND=0 D
. S CODEIEN=$P(^PXD(811.2,IEN,"SPR",IND,0),U,1)
.;DBIA #1995-A
. S TEMP=$$CPT^ICPTCOD(CODEIEN)
. S CODE=$P(TEMP,U,2)
. S ^TMP($J,NODE,"SPR",CODE)=TEMP
Q
;
;==========================================
CFR(IEN) ;Combine building selectable lists and copy from range.
D BLDCFR(IEN,"CFR")
D CFRANGE(IEN,"CFR")
Q
;
;==========================================
CFRANGE(IEN,NODE) ;Copy from a range of codes to the Lexicon based structure.
N CODE,CODEIEN,CODESYS,CSYS,CSYSIND,FDA,IENS,IND,HIGH,LOW,MSG
N NCODES,NUID,TEMP,TERM,TERMIND,UID
K ^TMP("PXRMCFR",$J)
F CODESYS="ICD","ICP","CPT" D
. S LOW=""
. F S LOW=$O(^TMP($J,NODE,CODESYS,LOW)) Q:LOW="" D
.. S HIGH=""
.. F S HIGH=$O(^TMP($J,NODE,CODESYS,LOW,HIGH)) Q:HIGH="" D
... S TERM="Copy from "_CODESYS_" range "_LOW_" to "_HIGH
...;Check for existing entries for this term and remove them before
...; storing the new set.
... I $D(^PXD(811.2,IEN,20,"B",TERM)) D
.... S TERMIND=$O(^PXD(811.2,IEN,20,"B",TERM,""))
.... S IENS=TERMIND_","_IEN_","
.... S FDA(811.23,IENS,.01)="@"
.... D FILE^DIE("","FDA","MSG")
... S CODE=LOW
... F Q:(CODE]HIGH)!(CODE="") D
....;DBIA #1997, #3991
.... S TEMP=$S(CODESYS="CPT":$$STATCHK^ICPTAPIU(CODE,""),1:$$STATCHK^ICDAPIU(CODE,""))
.... S CODEIEN=$P(TEMP,U,2)
.... I CODEIEN=-1 D Q
..... D MES^XPDUTL(" Warning - "_CODESYS_" code "_CODE_" is not valid.")
..... S CODE=$S(CODESYS="CPT":$$NEXT^ICPTAPIU(CODE),1:$$NEXT^ICDAPIU(CODE))
.... S UID=0
....;Mark as Use in Dialog if the code is marked as selectable.
.... I CODESYS="ICD",$D(^TMP($J,NODE,"SDX",CODE)) S UID=1
.... I CODESYS="CPT",$D(^TMP($J,NODE,"SPR",CODE)) S UID=1
.... S ^TMP("PXRMCFR",$J,TERM,CODESYS,CODE)=UID
.... S ^TMP($J,NODE,"STORED",CODESYS,CODE)=""
.... S CODE=$S(CODESYS="CPT":$$NEXT^ICPTAPIU(CODE),1:$$NEXT^ICDAPIU(CODE))
;
;Get selectable codes that are not in a range.
S TERM="Copy from selectable diagnosis"
;Check for existing entries for this term and remove them before
;storing the new set.
I $D(^PXD(811.2,IEN,20,"B",TERM)) D
. S TERMIND=$O(^PXD(811.2,IEN,20,"B",TERM,""))
. S IENS=TERMIND_","_IEN_","
. S FDA(811.23,IENS,.01)="@"
. D FILE^DIE("","FDA","MSG")
S CODE=""
F S CODE=$O(^TMP($J,NODE,"SDX",CODE)) Q:CODE="" D
.;Don't store codes that have already been stored.
. I $D(^TMP($J,NODE,"STORED","ICD",CODE)) Q
. S TEMP=^TMP($J,NODE,"SDX",CODE)
. I $P(TEMP,U,1)=-1 D Q
.. D MES^XPDUTL(" Warning - selectable code "_CODE_" is not valid.")
. S ^TMP("PXRMCFR",$J,TERM,"ICD",CODE)=1
;
S TERM="Copy from selectable procedure"
;Check for existing entries for this term and remove them before
;storing the new set.
I $D(^PXD(811.2,IEN,20,"B",TERM)) D
. S TERMIND=$O(^PXD(811.2,IEN,20,"B",TERM,""))
. S IENS=TERMIND_","_IEN_","
. S FDA(811.23,IENS,.01)="@"
. D FILE^DIE("","FDA","MSG")
S CODE=""
F S CODE=$O(^TMP($J,NODE,"SPR",CODE)) Q:CODE="" D
.;Don't store codes that have already been stored.
. I $D(^TMP($J,NODE,"STORED","CPT",CODE)) Q
. S TEMP=^TMP($J,NODE,"SPR",CODE)
. I $P(TEMP,U,1)=-1 D Q
.. D MES^XPDUTL(" Warning - selectable procedure "_CODE_" is not valid.")
. S ^TMP("PXRMCFR",$J,TERM,"CPT",CODE)=1
;
;The pointer based system did not differentiate between CPC and CPT
;codes, do that here.
S TERM=""
F S TERM=$O(^TMP("PXRMCFR",$J,TERM)) Q:TERM="" D
. I '$D(^TMP("PXRMCFR",$J,TERM,"CPT")) Q
. S CODE=""
. F S CODE=$O(^TMP("PXRMCFR",$J,TERM,"CPT",CODE)) Q:CODE="" D
..;DBIA #1995
.. S CSYS=$P($$CPT^ICPTCOD(CODE),U,5)
.. I CSYS="C" Q
.. S ^TMP("PXRMCFR",$J,TERM,"CPC",CODE)=^TMP("PXRMCFR",$J,TERM,"CPT",CODE)
;Remove extraneous CPT codes.
S TERM=""
F S TERM=$O(^TMP("PXRMCFR",$J,TERM)) Q:TERM="" D
. I '$D(^TMP("PXRMCFR",$J,TERM,"CPC")) Q
. S CODE=""
. F S CODE=$O(^TMP("PXRMCFR",$J,TERM,"CPC",CODE)) Q:CODE="" D
.. K ^TMP("PXRMCFR",$J,TERM,"CPT",CODE)
K ^TMP($J,NODE)
;
;Build the FDA and file it for each range.
S TERM="",TERMIND=0
F S TERM=$O(^TMP("PXRMCFR",$J,TERM)) Q:TERM="" D
. K FDA,MSG
. S TERMIND=TERMIND+1
. S IENS="+"_TERMIND_","_IEN_","
. S FDA(811.23,IENS,.01)=TERM
. S CODESYS="",CSYSIND=TERMIND
. F S CODESYS=$O(^TMP("PXRMCFR",$J,TERM,CODESYS)) Q:CODESYS="" D
.. S CSYSIND=CSYSIND+1
.. S CODE="",(NCODES,NUID)=0
.. F S CODE=$O(^TMP("PXRMCFR",$J,TERM,CODESYS,CODE)) Q:CODE="" D
... S NCODES=NCODES+1
... S IENS="+"_(NCODES+CSYSIND)_",+"_CSYSIND_",+"_TERMIND_","_IEN_","
... S UID=^TMP("PXRMCFR",$J,TERM,CODESYS,CODE)
... I UID=1 S NUID=NUID+1
... S FDA(811.2312,IENS,.01)=CODE
... S FDA(811.2312,IENS,1)=UID
.. S IENS="+"_CSYSIND_",+"_TERMIND_","_IEN_","
.. S FDA(811.231,IENS,.01)=CODESYS
.. S FDA(811.231,IENS,1)=NCODES
.. S FDA(811.231,IENS,3)=NUID
. D UPDATE^DIE("","FDA","","MSG")
K ^TMP("PXRMCFR",$J)
D CNTCHK(IEN)
Q
;
;==========================================
CNTCHK(IEN) ;Compare the number of codes stored under the old pointer
;structure with the number in the new structure.
N CODE,CODEIEN,NCPC,NCPT,NICD,NICD0,NICD9,NICP,NICPT,TEMP,TERM,TEXT
K ^TMP($J,"CPT"),^TMP($J,"ICD"),^TMP($J,"ICP")
;Rebuild the expansion to make sure it is current.
D EXPAND^PXRMBXTL(IEN,"")
S TEMP=$G(^PXD(811.3,IEN,0))
S NICD0=+$P(TEMP,U,3),NICD9=+$P(TEMP,U,5),NICPT=+$P(TEMP,U,7)
S (NCPC,NCPT,NICD,NICP)=0
I NICD0>0 D
. S TERM=""
. F S TERM=$O(^PXD(811.2,IEN,20,"ATCC",TERM)) Q:TERM="" D
.. I $E(TERM,1,13)'="Copy from ICP" Q
.. S CODE=""
.. F S CODE=$O(^PXD(811.2,IEN,20,"ATCC",TERM,"ICP",CODE)) Q:CODE="" D
... S CODEIEN=^PXD(811.2,IEN,20,"AE","ICP",CODE)
... S ^TMP($J,"ICP",CODEIEN)=CODE
.;Count the unqiue entries.
. S CODEIEN=""
. F S CODEIEN=$O(^TMP($J,"ICP",CODEIEN)) Q:CODEIEN="" S NICP=NICP+1
I NICD9>0 D
. S TERM=""
. F S TERM=$O(^PXD(811.2,IEN,20,"ATCC",TERM)) Q:TERM="" D
.. I $E(TERM,1,13)'="Copy from ICD" Q
.. S CODE=""
.. F S CODE=$O(^PXD(811.2,IEN,20,"ATCC",TERM,"ICD",CODE)) Q:CODE="" D
... S CODEIEN=^PXD(811.2,IEN,20,"AE","ICD",CODE)
... S ^TMP($J,"ICD",CODEIEN)=CODE
.;Count the unqiue entries.
. S CODEIEN=""
. F S CODEIEN=$O(^TMP($J,"ICD",CODEIEN)) Q:CODEIEN="" S NICD=NICD+1
I NICPT>0 D
. S TERM=""
. F S TERM=$O(^PXD(811.2,IEN,20,"ATCC",TERM)) Q:TERM="" D
.. I $E(TERM,1,13)'="Copy from CPT" Q
.. S CODE=""
.. F S CODE=$O(^PXD(811.2,IEN,20,"ATCC",TERM,"CPC",CODE)) Q:CODE="" D
... S NCPC=NCPC+1
... S CODEIEN=^PXD(811.2,IEN,20,"AE","CPC",CODE)
... S ^TMP($J,"CPT",CODEIEN)=CODE
.. S CODE=""
.. F S CODE=$O(^PXD(811.2,IEN,20,"ATCC",TERM,"CPT",CODE)) Q:CODE="" D
... S CODEIEN=^PXD(811.2,IEN,20,"AE","CPT",CODE)
... S ^TMP($J,"CPT",CODEIEN)=CODE
.;Count the unqiue entries.
. S CODEIEN=""
. F S CODEIEN=$O(^TMP($J,"CPT",CODEIEN)) Q:CODEIEN="" S NCPT=NCPT+1
I (NICD0>0),(NICD0'=NICP) D
. S TEXT(1)="Encountered a problem moving ICD-9 operation/procedure codes to the new structure."
. S TEXT(2)=" For taxonomy "_$P(^PXD(811.2,IEN,0),U,1)_" ("_IEN_")."
. S TEXT(3)=" Original number of codes: "_NICD0
. S TEXT(4)=" Number of copied codes: "_NICP
. D MES^XPDUTL(.TEXT)
I (NICD9>0),(NICD9'=NICD) D
. K TEXT
. S TEXT(1)="Encountered a problem moving ICD-9 diagnosis codes to the new structure."
. S TEXT(2)=" For taxonomy "_$P(^PXD(811.2,IEN,0),U,1)_" ("_IEN_")."
. S TEXT(3)=" Original number of codes: "_NICD9
. S TEXT(4)=" Number of copied codes: "_NICD
. D MES^XPDUTL(.TEXT)
I (NICPT>0),(NICPT'=NCPT) D
. K TEXT
. S TEXT(1)="Encountered a problem moving CPT codes to the new structure."
. S TEXT(2)=" For taxonomy "_$P(^PXD(811.2,IEN,0),U,1)_" ("_IEN_")."
. S TEXT(3)=" Original number of codes: "_NICPT
. S TEXT(4)=" Number of copied codes: "_(NCPC+NCPT)
. D MES^XPDUTL(.TEXT)
K ^TMP($J,"CPT"),^TMP($J,"ICD"),^TMP($J,"ICP")
Q
;
;==========================================
CPALL ;Do a range of codes copy for all taxonomies.
N IEN,NAME
D BMES^XPDUTL("Copying ranges of codes for all taxonomies.")
S NAME=""
F S NAME=$O(^PXD(811.2,"B",NAME)) Q:NAME="" D
. S IEN=$O(^PXD(811.2,"B",NAME,""))
. D MES^XPDUTL("Copy codes for taxonomy "_NAME_" (IEN="_IEN_")")
. D CFR(IEN)
K ^TMP($J,"PXRMDLG")
Q
;
;==========================================
EXCH(IEN,NODE) ;This entry point is used by Reminder Exchange to populate
;the Selected Codes multiple for taxonomies that were packed before
;the Selected Codes multiple existed.
;^TMP($J,NODE) is built in TAX^PXRMEXU0
I '$D(^TMP($J,NODE)) Q
D CFRANGE(IEN,NODE)
Q
;
PXRMTXCR ;SLC/PKR - Taxonomies, copy from a range. ;05/07/2014
+1 ;;2.0;CLINICAL REMINDERS;**26**;Feb 04, 2005;Build 404
+2 ;==========================================
BLDCFR(IEN,NODE) ;Build the range, selectable diagnosis, and selectable
+1 ;procedure lists.
+2 NEW CODE,CODEIEN,CODESYS,HIGH,IND,LOW,TNODE,TEMP
+3 KILL ^TMP($JOB,NODE)
+4 FOR CODESYS="ICD","ICP","CPT"
Begin DoDot:1
+5 SET TNODE=$SELECT(CODESYS="ICD":80,CODESYS="ICP":80.1,CODESYS="CPT":81)
+6 SET IND=0
+7 FOR
SET IND=+$ORDER(^PXD(811.2,IEN,TNODE,IND))
IF IND=0
QUIT
Begin DoDot:2
+8 SET TEMP=^PXD(811.2,IEN,TNODE,IND,0)
+9 SET LOW=$PIECE(TEMP,U,1)
SET HIGH=$PIECE(TEMP,U,2)
+10 IF HIGH=""
SET HIGH=LOW
+11 SET ^TMP($JOB,NODE,CODESYS,LOW,HIGH)=""
End DoDot:2
End DoDot:1
+12 ;
+13 SET IND=0
+14 FOR
SET IND=+$ORDER(^PXD(811.2,IEN,"SDX",IND))
IF IND=0
QUIT
Begin DoDot:1
+15 SET CODEIEN=$PIECE(^PXD(811.2,IEN,"SDX",IND,0),U,1)
+16 ;DBIA #5747
+17 SET TEMP=$$ICDDX^ICDEX(CODEIEN,DT,"ICD","I")
+18 SET CODE=$PIECE(TEMP,U,2)
+19 SET ^TMP($JOB,NODE,"SDX",CODE)=TEMP
End DoDot:1
+20 SET IND=0
+21 FOR
SET IND=+$ORDER(^PXD(811.2,IEN,"SPR",IND))
IF IND=0
QUIT
Begin DoDot:1
+22 SET CODEIEN=$PIECE(^PXD(811.2,IEN,"SPR",IND,0),U,1)
+23 ;DBIA #1995-A
+24 SET TEMP=$$CPT^ICPTCOD(CODEIEN)
+25 SET CODE=$PIECE(TEMP,U,2)
+26 SET ^TMP($JOB,NODE,"SPR",CODE)=TEMP
End DoDot:1
+27 QUIT
+28 ;
+29 ;==========================================
CFR(IEN) ;Combine building selectable lists and copy from range.
+1 DO BLDCFR(IEN,"CFR")
+2 DO CFRANGE(IEN,"CFR")
+3 QUIT
+4 ;
+5 ;==========================================
CFRANGE(IEN,NODE) ;Copy from a range of codes to the Lexicon based structure.
+1 NEW CODE,CODEIEN,CODESYS,CSYS,CSYSIND,FDA,IENS,IND,HIGH,LOW,MSG
+2 NEW NCODES,NUID,TEMP,TERM,TERMIND,UID
+3 KILL ^TMP("PXRMCFR",$JOB)
+4 FOR CODESYS="ICD","ICP","CPT"
Begin DoDot:1
+5 SET LOW=""
+6 FOR
SET LOW=$ORDER(^TMP($JOB,NODE,CODESYS,LOW))
IF LOW=""
QUIT
Begin DoDot:2
+7 SET HIGH=""
+8 FOR
SET HIGH=$ORDER(^TMP($JOB,NODE,CODESYS,LOW,HIGH))
IF HIGH=""
QUIT
Begin DoDot:3
+9 SET TERM="Copy from "_CODESYS_" range "_LOW_" to "_HIGH
+10 ;Check for existing entries for this term and remove them before
+11 ; storing the new set.
+12 IF $DATA(^PXD(811.2,IEN,20,"B",TERM))
Begin DoDot:4
+13 SET TERMIND=$ORDER(^PXD(811.2,IEN,20,"B",TERM,""))
+14 SET IENS=TERMIND_","_IEN_","
+15 SET FDA(811.23,IENS,.01)="@"
+16 DO FILE^DIE("","FDA","MSG")
End DoDot:4
+17 SET CODE=LOW
+18 FOR
IF (CODE]HIGH)!(CODE="")
QUIT
Begin DoDot:4
+19 ;DBIA #1997, #3991
+20 SET TEMP=$SELECT(CODESYS="CPT":$$STATCHK^ICPTAPIU(CODE,""),1:$$STATCHK^ICDAPIU(CODE,""))
+21 SET CODEIEN=$PIECE(TEMP,U,2)
+22 IF CODEIEN=-1
Begin DoDot:5
+23 DO MES^XPDUTL(" Warning - "_CODESYS_" code "_CODE_" is not valid.")
+24 SET CODE=$SELECT(CODESYS="CPT":$$NEXT^ICPTAPIU(CODE),1:$$NEXT^ICDAPIU(CODE))
End DoDot:5
QUIT
+25 SET UID=0
+26 ;Mark as Use in Dialog if the code is marked as selectable.
+27 IF CODESYS="ICD"
IF $DATA(^TMP($JOB,NODE,"SDX",CODE))
SET UID=1
+28 IF CODESYS="CPT"
IF $DATA(^TMP($JOB,NODE,"SPR",CODE))
SET UID=1
+29 SET ^TMP("PXRMCFR",$JOB,TERM,CODESYS,CODE)=UID
+30 SET ^TMP($JOB,NODE,"STORED",CODESYS,CODE)=""
+31 SET CODE=$SELECT(CODESYS="CPT":$$NEXT^ICPTAPIU(CODE),1:$$NEXT^ICDAPIU(CODE))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;
+33 ;Get selectable codes that are not in a range.
+34 SET TERM="Copy from selectable diagnosis"
+35 ;Check for existing entries for this term and remove them before
+36 ;storing the new set.
+37 IF $DATA(^PXD(811.2,IEN,20,"B",TERM))
Begin DoDot:1
+38 SET TERMIND=$ORDER(^PXD(811.2,IEN,20,"B",TERM,""))
+39 SET IENS=TERMIND_","_IEN_","
+40 SET FDA(811.23,IENS,.01)="@"
+41 DO FILE^DIE("","FDA","MSG")
End DoDot:1
+42 SET CODE=""
+43 FOR
SET CODE=$ORDER(^TMP($JOB,NODE,"SDX",CODE))
IF CODE=""
QUIT
Begin DoDot:1
+44 ;Don't store codes that have already been stored.
+45 IF $DATA(^TMP($JOB,NODE,"STORED","ICD",CODE))
QUIT
+46 SET TEMP=^TMP($JOB,NODE,"SDX",CODE)
+47 IF $PIECE(TEMP,U,1)=-1
Begin DoDot:2
+48 DO MES^XPDUTL(" Warning - selectable code "_CODE_" is not valid.")
End DoDot:2
QUIT
+49 SET ^TMP("PXRMCFR",$JOB,TERM,"ICD",CODE)=1
End DoDot:1
+50 ;
+51 SET TERM="Copy from selectable procedure"
+52 ;Check for existing entries for this term and remove them before
+53 ;storing the new set.
+54 IF $DATA(^PXD(811.2,IEN,20,"B",TERM))
Begin DoDot:1
+55 SET TERMIND=$ORDER(^PXD(811.2,IEN,20,"B",TERM,""))
+56 SET IENS=TERMIND_","_IEN_","
+57 SET FDA(811.23,IENS,.01)="@"
+58 DO FILE^DIE("","FDA","MSG")
End DoDot:1
+59 SET CODE=""
+60 FOR
SET CODE=$ORDER(^TMP($JOB,NODE,"SPR",CODE))
IF CODE=""
QUIT
Begin DoDot:1
+61 ;Don't store codes that have already been stored.
+62 IF $DATA(^TMP($JOB,NODE,"STORED","CPT",CODE))
QUIT
+63 SET TEMP=^TMP($JOB,NODE,"SPR",CODE)
+64 IF $PIECE(TEMP,U,1)=-1
Begin DoDot:2
+65 DO MES^XPDUTL(" Warning - selectable procedure "_CODE_" is not valid.")
End DoDot:2
QUIT
+66 SET ^TMP("PXRMCFR",$JOB,TERM,"CPT",CODE)=1
End DoDot:1
+67 ;
+68 ;The pointer based system did not differentiate between CPC and CPT
+69 ;codes, do that here.
+70 SET TERM=""
+71 FOR
SET TERM=$ORDER(^TMP("PXRMCFR",$JOB,TERM))
IF TERM=""
QUIT
Begin DoDot:1
+72 IF '$DATA(^TMP("PXRMCFR",$JOB,TERM,"CPT"))
QUIT
+73 SET CODE=""
+74 FOR
SET CODE=$ORDER(^TMP("PXRMCFR",$JOB,TERM,"CPT",CODE))
IF CODE=""
QUIT
Begin DoDot:2
+75 ;DBIA #1995
+76 SET CSYS=$PIECE($$CPT^ICPTCOD(CODE),U,5)
+77 IF CSYS="C"
QUIT
+78 SET ^TMP("PXRMCFR",$JOB,TERM,"CPC",CODE)=^TMP("PXRMCFR",$JOB,TERM,"CPT",CODE)
End DoDot:2
End DoDot:1
+79 ;Remove extraneous CPT codes.
+80 SET TERM=""
+81 FOR
SET TERM=$ORDER(^TMP("PXRMCFR",$JOB,TERM))
IF TERM=""
QUIT
Begin DoDot:1
+82 IF '$DATA(^TMP("PXRMCFR",$JOB,TERM,"CPC"))
QUIT
+83 SET CODE=""
+84 FOR
SET CODE=$ORDER(^TMP("PXRMCFR",$JOB,TERM,"CPC",CODE))
IF CODE=""
QUIT
Begin DoDot:2
+85 KILL ^TMP("PXRMCFR",$JOB,TERM,"CPT",CODE)
End DoDot:2
End DoDot:1
+86 KILL ^TMP($JOB,NODE)
+87 ;
+88 ;Build the FDA and file it for each range.
+89 SET TERM=""
SET TERMIND=0
+90 FOR
SET TERM=$ORDER(^TMP("PXRMCFR",$JOB,TERM))
IF TERM=""
QUIT
Begin DoDot:1
+91 KILL FDA,MSG
+92 SET TERMIND=TERMIND+1
+93 SET IENS="+"_TERMIND_","_IEN_","
+94 SET FDA(811.23,IENS,.01)=TERM
+95 SET CODESYS=""
SET CSYSIND=TERMIND
+96 FOR
SET CODESYS=$ORDER(^TMP("PXRMCFR",$JOB,TERM,CODESYS))
IF CODESYS=""
QUIT
Begin DoDot:2
+97 SET CSYSIND=CSYSIND+1
+98 SET CODE=""
SET (NCODES,NUID)=0
+99 FOR
SET CODE=$ORDER(^TMP("PXRMCFR",$JOB,TERM,CODESYS,CODE))
IF CODE=""
QUIT
Begin DoDot:3
+100 SET NCODES=NCODES+1
+101 SET IENS="+"_(NCODES+CSYSIND)_",+"_CSYSIND_",+"_TERMIND_","_IEN_","
+102 SET UID=^TMP("PXRMCFR",$JOB,TERM,CODESYS,CODE)
+103 IF UID=1
SET NUID=NUID+1
+104 SET FDA(811.2312,IENS,.01)=CODE
+105 SET FDA(811.2312,IENS,1)=UID
End DoDot:3
+106 SET IENS="+"_CSYSIND_",+"_TERMIND_","_IEN_","
+107 SET FDA(811.231,IENS,.01)=CODESYS
+108 SET FDA(811.231,IENS,1)=NCODES
+109 SET FDA(811.231,IENS,3)=NUID
End DoDot:2
+110 DO UPDATE^DIE("","FDA","","MSG")
End DoDot:1
+111 KILL ^TMP("PXRMCFR",$JOB)
+112 DO CNTCHK(IEN)
+113 QUIT
+114 ;
+115 ;==========================================
CNTCHK(IEN) ;Compare the number of codes stored under the old pointer
+1 ;structure with the number in the new structure.
+2 NEW CODE,CODEIEN,NCPC,NCPT,NICD,NICD0,NICD9,NICP,NICPT,TEMP,TERM,TEXT
+3 KILL ^TMP($JOB,"CPT"),^TMP($JOB,"ICD"),^TMP($JOB,"ICP")
+4 ;Rebuild the expansion to make sure it is current.
+5 DO EXPAND^PXRMBXTL(IEN,"")
+6 SET TEMP=$GET(^PXD(811.3,IEN,0))
+7 SET NICD0=+$PIECE(TEMP,U,3)
SET NICD9=+$PIECE(TEMP,U,5)
SET NICPT=+$PIECE(TEMP,U,7)
+8 SET (NCPC,NCPT,NICD,NICP)=0
+9 IF NICD0>0
Begin DoDot:1
+10 SET TERM=""
+11 FOR
SET TERM=$ORDER(^PXD(811.2,IEN,20,"ATCC",TERM))
IF TERM=""
QUIT
Begin DoDot:2
+12 IF $EXTRACT(TERM,1,13)'="Copy from ICP"
QUIT
+13 SET CODE=""
+14 FOR
SET CODE=$ORDER(^PXD(811.2,IEN,20,"ATCC",TERM,"ICP",CODE))
IF CODE=""
QUIT
Begin DoDot:3
+15 SET CODEIEN=^PXD(811.2,IEN,20,"AE","ICP",CODE)
+16 SET ^TMP($JOB,"ICP",CODEIEN)=CODE
End DoDot:3
End DoDot:2
+17 ;Count the unqiue entries.
+18 SET CODEIEN=""
+19 FOR
SET CODEIEN=$ORDER(^TMP($JOB,"ICP",CODEIEN))
IF CODEIEN=""
QUIT
SET NICP=NICP+1
End DoDot:1
+20 IF NICD9>0
Begin DoDot:1
+21 SET TERM=""
+22 FOR
SET TERM=$ORDER(^PXD(811.2,IEN,20,"ATCC",TERM))
IF TERM=""
QUIT
Begin DoDot:2
+23 IF $EXTRACT(TERM,1,13)'="Copy from ICD"
QUIT
+24 SET CODE=""
+25 FOR
SET CODE=$ORDER(^PXD(811.2,IEN,20,"ATCC",TERM,"ICD",CODE))
IF CODE=""
QUIT
Begin DoDot:3
+26 SET CODEIEN=^PXD(811.2,IEN,20,"AE","ICD",CODE)
+27 SET ^TMP($JOB,"ICD",CODEIEN)=CODE
End DoDot:3
End DoDot:2
+28 ;Count the unqiue entries.
+29 SET CODEIEN=""
+30 FOR
SET CODEIEN=$ORDER(^TMP($JOB,"ICD",CODEIEN))
IF CODEIEN=""
QUIT
SET NICD=NICD+1
End DoDot:1
+31 IF NICPT>0
Begin DoDot:1
+32 SET TERM=""
+33 FOR
SET TERM=$ORDER(^PXD(811.2,IEN,20,"ATCC",TERM))
IF TERM=""
QUIT
Begin DoDot:2
+34 IF $EXTRACT(TERM,1,13)'="Copy from CPT"
QUIT
+35 SET CODE=""
+36 FOR
SET CODE=$ORDER(^PXD(811.2,IEN,20,"ATCC",TERM,"CPC",CODE))
IF CODE=""
QUIT
Begin DoDot:3
+37 SET NCPC=NCPC+1
+38 SET CODEIEN=^PXD(811.2,IEN,20,"AE","CPC",CODE)
+39 SET ^TMP($JOB,"CPT",CODEIEN)=CODE
End DoDot:3
+40 SET CODE=""
+41 FOR
SET CODE=$ORDER(^PXD(811.2,IEN,20,"ATCC",TERM,"CPT",CODE))
IF CODE=""
QUIT
Begin DoDot:3
+42 SET CODEIEN=^PXD(811.2,IEN,20,"AE","CPT",CODE)
+43 SET ^TMP($JOB,"CPT",CODEIEN)=CODE
End DoDot:3
End DoDot:2
+44 ;Count the unqiue entries.
+45 SET CODEIEN=""
+46 FOR
SET CODEIEN=$ORDER(^TMP($JOB,"CPT",CODEIEN))
IF CODEIEN=""
QUIT
SET NCPT=NCPT+1
End DoDot:1
+47 IF (NICD0>0)
IF (NICD0'=NICP)
Begin DoDot:1
+48 SET TEXT(1)="Encountered a problem moving ICD-9 operation/procedure codes to the new structure."
+49 SET TEXT(2)=" For taxonomy "_$PIECE(^PXD(811.2,IEN,0),U,1)_" ("_IEN_")."
+50 SET TEXT(3)=" Original number of codes: "_NICD0
+51 SET TEXT(4)=" Number of copied codes: "_NICP
+52 DO MES^XPDUTL(.TEXT)
End DoDot:1
+53 IF (NICD9>0)
IF (NICD9'=NICD)
Begin DoDot:1
+54 KILL TEXT
+55 SET TEXT(1)="Encountered a problem moving ICD-9 diagnosis codes to the new structure."
+56 SET TEXT(2)=" For taxonomy "_$PIECE(^PXD(811.2,IEN,0),U,1)_" ("_IEN_")."
+57 SET TEXT(3)=" Original number of codes: "_NICD9
+58 SET TEXT(4)=" Number of copied codes: "_NICD
+59 DO MES^XPDUTL(.TEXT)
End DoDot:1
+60 IF (NICPT>0)
IF (NICPT'=NCPT)
Begin DoDot:1
+61 KILL TEXT
+62 SET TEXT(1)="Encountered a problem moving CPT codes to the new structure."
+63 SET TEXT(2)=" For taxonomy "_$PIECE(^PXD(811.2,IEN,0),U,1)_" ("_IEN_")."
+64 SET TEXT(3)=" Original number of codes: "_NICPT
+65 SET TEXT(4)=" Number of copied codes: "_(NCPC+NCPT)
+66 DO MES^XPDUTL(.TEXT)
End DoDot:1
+67 KILL ^TMP($JOB,"CPT"),^TMP($JOB,"ICD"),^TMP($JOB,"ICP")
+68 QUIT
+69 ;
+70 ;==========================================
CPALL ;Do a range of codes copy for all taxonomies.
+1 NEW IEN,NAME
+2 DO BMES^XPDUTL("Copying ranges of codes for all taxonomies.")
+3 SET NAME=""
+4 FOR
SET NAME=$ORDER(^PXD(811.2,"B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+5 SET IEN=$ORDER(^PXD(811.2,"B",NAME,""))
+6 DO MES^XPDUTL("Copy codes for taxonomy "_NAME_" (IEN="_IEN_")")
+7 DO CFR(IEN)
End DoDot:1
+8 KILL ^TMP($JOB,"PXRMDLG")
+9 QUIT
+10 ;
+11 ;==========================================
EXCH(IEN,NODE) ;This entry point is used by Reminder Exchange to populate
+1 ;the Selected Codes multiple for taxonomies that were packed before
+2 ;the Selected Codes multiple existed.
+3 ;^TMP($J,NODE) is built in TAX^PXRMEXU0
+4 IF '$DATA(^TMP($JOB,NODE))
QUIT
+5 DO CFRANGE(IEN,NODE)
+6 QUIT
+7 ;
