PXRMTXCR ;SLC/PKR - Taxonomies, copy from a range. ;04/01/2015
;;2.0;CLINICAL REMINDERS;**26,47**;Feb 04, 2005;Build 291
;==========================================
CBDES(IEN,NODE) ;Copy the Brief Description to the description.
I '$D(^TMP($J,NODE,"BDES")) Q
S ^PXD(811.2,IEN,1,0)="^^1^1^"_DT_"^^"
S ^PXD(811.2,IEN,1,1,0)=^TMP($J,NODE,"BDES")
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
N PXRMCFR S PXRMCFR=1
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)
;Build the 30 node.
K PXRMCFR
D BLD30N^PXRMTAXD(IEN)
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 CBDES(IEN,NODE)
D CFRANGE(IEN,NODE)
K ^TMP($J,NODE)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMTXCR 5350 printed Apr 09, 2024@20:49:23 Page 2
PXRMTXCR ;SLC/PKR - Taxonomies, copy from a range. ;04/01/2015
+1 ;;2.0;CLINICAL REMINDERS;**26,47**;Feb 04, 2005;Build 291
+2 ;==========================================
CBDES(IEN,NODE) ;Copy the Brief Description to the description.
+1 IF '$DATA(^TMP($JOB,NODE,"BDES"))
QUIT
+2 SET ^PXD(811.2,IEN,1,0)="^^1^1^"_DT_"^^"
+3 SET ^PXD(811.2,IEN,1,1,0)=^TMP($JOB,NODE,"BDES")
+4 QUIT
+5 ;
+6 ;==========================================
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 NEW PXRMCFR
SET PXRMCFR=1
+4 KILL ^TMP("PXRMCFR",$JOB)
+5 FOR CODESYS="ICD","ICP","CPT"
Begin DoDot:1
+6 SET LOW=""
+7 FOR
SET LOW=$ORDER(^TMP($JOB,NODE,CODESYS,LOW))
if LOW=""
QUIT
Begin DoDot:2
+8 SET HIGH=""
+9 FOR
SET HIGH=$ORDER(^TMP($JOB,NODE,CODESYS,LOW,HIGH))
if HIGH=""
QUIT
Begin DoDot:3
+10 SET TERM="Copy from "_CODESYS_" range "_LOW_" to "_HIGH
+11 ;Check for existing entries for this term and remove them before
+12 ;storing the new set.
+13 IF $DATA(^PXD(811.2,IEN,20,"B",TERM))
Begin DoDot:4
+14 SET TERMIND=$ORDER(^PXD(811.2,IEN,20,"B",TERM,""))
+15 SET IENS=TERMIND_","_IEN_","
+16 SET FDA(811.23,IENS,.01)="@"
+17 DO FILE^DIE("","FDA","MSG")
End DoDot:4
+18 SET CODE=LOW
+19 FOR
if (CODE]HIGH)!(CODE="")
QUIT
Begin DoDot:4
+20 ;DBIA #1997, #3991
+21 SET TEMP=$SELECT(CODESYS="CPT":$$STATCHK^ICPTAPIU(CODE,""),1:$$STATCHK^ICDAPIU(CODE,""))
+22 SET CODEIEN=$PIECE(TEMP,U,2)
+23 IF CODEIEN=-1
Begin DoDot:5
+24 DO MES^XPDUTL(" Warning - "_CODESYS_" code "_CODE_" is not valid.")
+25 SET CODE=$SELECT(CODESYS="CPT":$$NEXT^ICPTAPIU(CODE),1:$$NEXT^ICDAPIU(CODE))
End DoDot:5
QUIT
+26 SET UID=0
+27 ;Mark as Use in Dialog if the code is marked as selectable.
+28 IF CODESYS="ICD"
IF $DATA(^TMP($JOB,NODE,"SDX",CODE))
SET UID=1
+29 IF CODESYS="CPT"
IF $DATA(^TMP($JOB,NODE,"SPR",CODE))
SET UID=1
+30 SET ^TMP("PXRMCFR",$JOB,TERM,CODESYS,CODE)=UID
+31 SET ^TMP($JOB,NODE,"STORED",CODESYS,CODE)=""
+32 SET CODE=$SELECT(CODESYS="CPT":$$NEXT^ICPTAPIU(CODE),1:$$NEXT^ICDAPIU(CODE))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;
+34 ;Get selectable codes that are not in a range.
+35 SET TERM="Copy from selectable diagnosis"
+36 ;Check for existing entries for this term and remove them before
+37 ;storing the new set.
+38 IF $DATA(^PXD(811.2,IEN,20,"B",TERM))
Begin DoDot:1
+39 SET TERMIND=$ORDER(^PXD(811.2,IEN,20,"B",TERM,""))
+40 SET IENS=TERMIND_","_IEN_","
+41 SET FDA(811.23,IENS,.01)="@"
+42 DO FILE^DIE("","FDA","MSG")
End DoDot:1
+43 SET CODE=""
+44 FOR
SET CODE=$ORDER(^TMP($JOB,NODE,"SDX",CODE))
if CODE=""
QUIT
Begin DoDot:1
+45 ;Don't store codes that have already been stored.
+46 IF $DATA(^TMP($JOB,NODE,"STORED","ICD",CODE))
QUIT
+47 SET TEMP=^TMP($JOB,NODE,"SDX",CODE)
+48 IF $PIECE(TEMP,U,1)=-1
Begin DoDot:2
+49 DO MES^XPDUTL(" Warning - selectable code "_CODE_" is not valid.")
End DoDot:2
QUIT
+50 SET ^TMP("PXRMCFR",$JOB,TERM,"ICD",CODE)=1
End DoDot:1
+51 ;
+52 SET TERM="Copy from selectable procedure"
+53 ;Check for existing entries for this term and remove them before
+54 ;storing the new set.
+55 IF $DATA(^PXD(811.2,IEN,20,"B",TERM))
Begin DoDot:1
+56 SET TERMIND=$ORDER(^PXD(811.2,IEN,20,"B",TERM,""))
+57 SET IENS=TERMIND_","_IEN_","
+58 SET FDA(811.23,IENS,.01)="@"
+59 DO FILE^DIE("","FDA","MSG")
End DoDot:1
+60 SET CODE=""
+61 FOR
SET CODE=$ORDER(^TMP($JOB,NODE,"SPR",CODE))
if CODE=""
QUIT
Begin DoDot:1
+62 ;Don't store codes that have already been stored.
+63 IF $DATA(^TMP($JOB,NODE,"STORED","CPT",CODE))
QUIT
+64 SET TEMP=^TMP($JOB,NODE,"SPR",CODE)
+65 IF $PIECE(TEMP,U,1)=-1
Begin DoDot:2
+66 DO MES^XPDUTL(" Warning - selectable procedure "_CODE_" is not valid.")
End DoDot:2
QUIT
+67 SET ^TMP("PXRMCFR",$JOB,TERM,"CPT",CODE)=1
End DoDot:1
+68 ;
+69 ;The pointer based system did not differentiate between CPC and CPT
+70 ;codes, do that here.
+71 SET TERM=""
+72 FOR
SET TERM=$ORDER(^TMP("PXRMCFR",$JOB,TERM))
if TERM=""
QUIT
Begin DoDot:1
+73 IF '$DATA(^TMP("PXRMCFR",$JOB,TERM,"CPT"))
QUIT
+74 SET CODE=""
+75 FOR
SET CODE=$ORDER(^TMP("PXRMCFR",$JOB,TERM,"CPT",CODE))
if CODE=""
QUIT
Begin DoDot:2
+76 ;DBIA #1995
+77 SET CSYS=$PIECE($$CPT^ICPTCOD(CODE),U,5)
+78 IF CSYS="C"
QUIT
+79 SET ^TMP("PXRMCFR",$JOB,TERM,"CPC",CODE)=^TMP("PXRMCFR",$JOB,TERM,"CPT",CODE)
End DoDot:2
End DoDot:1
+80 ;Remove extraneous CPT codes.
+81 SET TERM=""
+82 FOR
SET TERM=$ORDER(^TMP("PXRMCFR",$JOB,TERM))
if TERM=""
QUIT
Begin DoDot:1
+83 IF '$DATA(^TMP("PXRMCFR",$JOB,TERM,"CPC"))
QUIT
+84 SET CODE=""
+85 FOR
SET CODE=$ORDER(^TMP("PXRMCFR",$JOB,TERM,"CPC",CODE))
if CODE=""
QUIT
Begin DoDot:2
+86 KILL ^TMP("PXRMCFR",$JOB,TERM,"CPT",CODE)
End DoDot:2
End DoDot:1
+87 KILL ^TMP($JOB,NODE)
+88 ;
+89 ;Build the FDA and file it for each range.
+90 SET TERM=""
SET TERMIND=0
+91 FOR
SET TERM=$ORDER(^TMP("PXRMCFR",$JOB,TERM))
if TERM=""
QUIT
Begin DoDot:1
+92 KILL FDA,MSG
+93 SET TERMIND=TERMIND+1
+94 SET IENS="+"_TERMIND_","_IEN_","
+95 SET FDA(811.23,IENS,.01)=TERM
+96 SET CODESYS=""
SET CSYSIND=TERMIND
+97 FOR
SET CODESYS=$ORDER(^TMP("PXRMCFR",$JOB,TERM,CODESYS))
if CODESYS=""
QUIT
Begin DoDot:2
+98 SET CSYSIND=CSYSIND+1
+99 SET CODE=""
SET (NCODES,NUID)=0
+100 FOR
SET CODE=$ORDER(^TMP("PXRMCFR",$JOB,TERM,CODESYS,CODE))
if CODE=""
QUIT
Begin DoDot:3
+101 SET NCODES=NCODES+1
+102 SET IENS="+"_(NCODES+CSYSIND)_",+"_CSYSIND_",+"_TERMIND_","_IEN_","
+103 SET UID=^TMP("PXRMCFR",$JOB,TERM,CODESYS,CODE)
+104 IF UID=1
SET NUID=NUID+1
+105 SET FDA(811.2312,IENS,.01)=CODE
+106 SET FDA(811.2312,IENS,1)=UID
End DoDot:3
+107 SET IENS="+"_CSYSIND_",+"_TERMIND_","_IEN_","
+108 SET FDA(811.231,IENS,.01)=CODESYS
+109 SET FDA(811.231,IENS,1)=NCODES
+110 SET FDA(811.231,IENS,3)=NUID
End DoDot:2
+111 DO UPDATE^DIE("","FDA","","MSG")
End DoDot:1
+112 KILL ^TMP("PXRMCFR",$JOB)
+113 ;Build the 30 node.
+114 KILL PXRMCFR
+115 DO BLD30N^PXRMTAXD(IEN)
+116 QUIT
+117 ;
+118 ;==========================================
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 CBDES(IEN,NODE)
+6 DO CFRANGE(IEN,NODE)
+7 KILL ^TMP($JOB,NODE)
+8 QUIT
+9 ;
