PXRMTECK ; SLC/PKR - Check expanded taxonomies. ;02/25/2009
;;2.0;CLINICAL REMINDERS;**12**;Feb 04, 2005;Build 73
;
;====================================================
ALL ;Check all expansions.
N IEN,IO,NAME,POP,TEXT
W !,"Verify all taxonomy expansions."
D ^%ZIS
I POP Q
U IO
W !,"Checking all taxonomy expansions."
S NAME=""
F S NAME=$O(^PXD(811.2,"B",NAME)) Q:NAME="" D
. S IEN=$O(^PXD(811.2,"B",NAME,""))
. D CHECK(IEN)
D ^%ZISC
Q
;
;====================================================
CHECK(IEN) ;Check an expansion.
;Save existing expansion.
N CODE,EXPOK,HIGH,IND,LOW,NAME,TEMP,TYPE
S NAME=$P(^PXD(811.2,IEN,0),U,1)
W !!,"Taxonomy: ",NAME," (IEN=",IEN,")"
I '$D(^PXD(811.3,IEN)) W !,"Expansion does not exist." Q
K ^TMP($J,"CUREXP"),^TMP($J,"NEWEXP")
I $D(^PXD(811.3,IEN,80,"ICD9P")) M ^TMP($J,"CUREXP","ICD 9")=^PXD(811.3,IEN,80,"ICD9P")
I $D(^PXD(811.3,IEN,80.1,"ICD0P")) M ^TMP($J,"CUREXP","ICD 0")=^PXD(811.3,IEN,80.1,"ICD0P")
I $D(^PXD(811.3,IEN,81,"ICPTP")) M ^TMP($J,"CUREXP","CPT")=^PXD(811.3,IEN,81,"ICPTP")
;Rexpand
S IND=0
F S IND=+$O(^PXD(811.2,IEN,80.1,IND)) Q:IND=0 D
. S TEMP=^PXD(811.2,IEN,80.1,IND,0)
. S LOW=$P(TEMP,U,1)
. S HIGH=$P(TEMP,U,2)
. I HIGH="" S HIGH=LOW
. D ICD0(IEN,LOW,HIGH,"NEWEXP")
;
S IND=0
F S IND=+$O(^PXD(811.2,IEN,80,IND)) Q:IND=0 D
. S TEMP=^PXD(811.2,IEN,80,IND,0)
. S LOW=$P(TEMP,U,1)
. S HIGH=$P(TEMP,U,2)
. I HIGH="" S HIGH=LOW
. D ICD9(IEN,LOW,HIGH,"NEWEXP")
;
S IND=0
F S IND=+$O(^PXD(811.2,IEN,81,IND)) Q:IND=0 D
. S TEMP=^PXD(811.2,IEN,81,IND,0)
. S LOW=$P(TEMP,U,1)
. S HIGH=$P(TEMP,U,2)
. I HIGH="" S HIGH=LOW
. D ICPT(IEN,LOW,HIGH,"NEWEXP")
;Do the comparsions.
S EXPOK=1
W !,"Expansion was last built on ",$$FMTE^XLFDT($P(^PXD(811.3,IEN,0),U,2),"5Z")
F TYPE="ICD 9","ICD 0","CPT" D
. S CODE=""
. F S CODE=$O(^TMP($J,"NEWEXP",TYPE,CODE)) Q:CODE="" D
.. I $D(^TMP($J,"CUREXP",TYPE,CODE)) K ^TMP($J,"CUREXP",TYPE,CODE),^TMP($J,"NEWEXP",TYPE,CODE)
I $D(^TMP($J,"NEWEXP")) D
. S EXPOK=0
. W !!,"The following codes are missing from the expansion:"
. D OUTPUT("NEWEXP")
I $D(^TMP($J,"CUREXP")) D
. S EXPOK=0
. W !!,"The following codes are in the expansion and they should not be:"
. D OUTPUT("CUREXP")
I EXPOK W !,"The expansion is correct."
K ^TMP($J,"CUREXP"),^TMP($J,"NEWEXP")
Q
;
;====================================================
ICD0(TAXIEN,LOW,HIGH,SUB) ;Build the list of internal entries for ICD0
;(File 80.1). Use of ICDAPIU: DBIA #3991
N CODE,IEN,TEMP
S CODE=LOW
F Q:(CODE]HIGH)!(CODE="") D
. S TEMP=$$STATCHK^ICDAPIU(CODE,"")
. S IEN=$P(TEMP,U,2)
. I IEN'=-1,'$D(^TMP($J,SUB,"ICD 0",IEN)) D
.. S ^TMP($J,SUB,"ICD 0",IEN)=""
. S CODE=$$NEXT^ICDAPIU(CODE)
Q
;
;====================================================
ICD9(TAXIEN,LOW,HIGH,SUB) ;Build the list of internal entries for ICD9
;(File 80). Use of ICDAPIU: DBIA #3991
N CODE,IEN,TEMP
S CODE=LOW
F Q:(CODE]HIGH)!(CODE="") D
. S TEMP=$$STATCHK^ICDAPIU(CODE,"")
. S IEN=$P(TEMP,U,2)
. I IEN'=-1,'$D(^TMP(SUB,"ICD 9",IEN)) D
.. S ^TMP($J,SUB,"ICD 9",IEN)=""
. S CODE=$$NEXT^ICDAPIU(CODE)
Q
;
;====================================================
ICPT(TAXIEN,LOW,HIGH,SUB) ;Build the list of internal entries
;for ICPT (File 81). Use of ICDAPIU: DBIA #3991
N CODE,IEN,RADIEN,TEMP
S CODE=LOW
F Q:(CODE]HIGH)!(CODE="") D
. S TEMP=$$STATCHK^ICPTAPIU(CODE,"")
. S IEN=$P(TEMP,U,2)
. I IEN'=-1,'$D(^TMP($J,SUB,"CPT",IEN)) D
.. S ^TMP($J,SUB,"CPT",IEN)=""
. S CODE=$$NEXT^ICPTAPIU(CODE)
Q
;
;====================================================
OUTPUT(SUB) ;Output codes that are left.
;References to ICDCODE DBIA #3990.
;References to ICPTCOD DBIA #1995.
N IEN,LIST,NUM,TEMP,TYPE
K LIST
S TYPE=""
F S TYPE=$O(^TMP($J,SUB,TYPE)) Q:TYPE="" D
. W !," ",TYPE," codes:"
. S IEN=0
. F S IEN=$O(^TMP($J,SUB,TYPE,IEN)) Q:IEN="" D
.. I TYPE="CPT" D
... S CODE=$$CPT^ICPTCOD(IEN,DT)
... S TEMP=$P(CODE,U,3)
.. I TYPE="ICD 0" D
... S CODE=$$ICDOP^ICDCODE(IEN,DT)
... S TEMP=$P(CODE,U,5)
.. I TYPE="ICD 9" D
... S CODE=$$ICDDX^ICDCODE(IEN,DT)
... S TEMP=$P(CODE,U,4)
.. S TEMP=$E(TEMP,1,30)
.. S LIST($P(CODE,U,2)_" ")=$$LJ^XLFSTR(TEMP,30)_" (IEN="_IEN_")"
. S CODE="",NUM=0
. F S CODE=$O(LIST(CODE)) Q:CODE="" D
.. S NUM=NUM+1
.. W !,$$RJ^XLFSTR(NUM,4)," ",$$LJ^XLFSTR(CODE,9),LIST(CODE)
Q
;
PXRMTECK ; SLC/PKR - Check expanded taxonomies. ;02/25/2009
+1 ;;2.0;CLINICAL REMINDERS;**12**;Feb 04, 2005;Build 73
+2 ;
+3 ;====================================================
ALL ;Check all expansions.
+1 NEW IEN,IO,NAME,POP,TEXT
+2 WRITE !,"Verify all taxonomy expansions."
+3 DO ^%ZIS
+4 IF POP
QUIT
+5 USE IO
+6 WRITE !,"Checking all taxonomy expansions."
+7 SET NAME=""
+8 FOR
SET NAME=$ORDER(^PXD(811.2,"B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+9 SET IEN=$ORDER(^PXD(811.2,"B",NAME,""))
+10 DO CHECK(IEN)
End DoDot:1
+11 DO ^%ZISC
+12 QUIT
+13 ;
+14 ;====================================================
CHECK(IEN) ;Check an expansion.
+1 ;Save existing expansion.
+2 NEW CODE,EXPOK,HIGH,IND,LOW,NAME,TEMP,TYPE
+3 SET NAME=$PIECE(^PXD(811.2,IEN,0),U,1)
+4 WRITE !!,"Taxonomy: ",NAME," (IEN=",IEN,")"
+5 IF '$DATA(^PXD(811.3,IEN))
WRITE !,"Expansion does not exist."
QUIT
+6 KILL ^TMP($JOB,"CUREXP"),^TMP($JOB,"NEWEXP")
+7 IF $DATA(^PXD(811.3,IEN,80,"ICD9P"))
MERGE ^TMP($JOB,"CUREXP","ICD 9")=^PXD(811.3,IEN,80,"ICD9P")
+8 IF $DATA(^PXD(811.3,IEN,80.1,"ICD0P"))
MERGE ^TMP($JOB,"CUREXP","ICD 0")=^PXD(811.3,IEN,80.1,"ICD0P")
+9 IF $DATA(^PXD(811.3,IEN,81,"ICPTP"))
MERGE ^TMP($JOB,"CUREXP","CPT")=^PXD(811.3,IEN,81,"ICPTP")
+10 ;Rexpand
+11 SET IND=0
+12 FOR
SET IND=+$ORDER(^PXD(811.2,IEN,80.1,IND))
IF IND=0
QUIT
Begin DoDot:1
+13 SET TEMP=^PXD(811.2,IEN,80.1,IND,0)
+14 SET LOW=$PIECE(TEMP,U,1)
+15 SET HIGH=$PIECE(TEMP,U,2)
+16 IF HIGH=""
SET HIGH=LOW
+17 DO ICD0(IEN,LOW,HIGH,"NEWEXP")
End DoDot:1
+18 ;
+19 SET IND=0
+20 FOR
SET IND=+$ORDER(^PXD(811.2,IEN,80,IND))
IF IND=0
QUIT
Begin DoDot:1
+21 SET TEMP=^PXD(811.2,IEN,80,IND,0)
+22 SET LOW=$PIECE(TEMP,U,1)
+23 SET HIGH=$PIECE(TEMP,U,2)
+24 IF HIGH=""
SET HIGH=LOW
+25 DO ICD9(IEN,LOW,HIGH,"NEWEXP")
End DoDot:1
+26 ;
+27 SET IND=0
+28 FOR
SET IND=+$ORDER(^PXD(811.2,IEN,81,IND))
IF IND=0
QUIT
Begin DoDot:1
+29 SET TEMP=^PXD(811.2,IEN,81,IND,0)
+30 SET LOW=$PIECE(TEMP,U,1)
+31 SET HIGH=$PIECE(TEMP,U,2)
+32 IF HIGH=""
SET HIGH=LOW
+33 DO ICPT(IEN,LOW,HIGH,"NEWEXP")
End DoDot:1
+34 ;Do the comparsions.
+35 SET EXPOK=1
+36 WRITE !,"Expansion was last built on ",$$FMTE^XLFDT($PIECE(^PXD(811.3,IEN,0),U,2),"5Z")
+37 FOR TYPE="ICD 9","ICD 0","CPT"
Begin DoDot:1
+38 SET CODE=""
+39 FOR
SET CODE=$ORDER(^TMP($JOB,"NEWEXP",TYPE,CODE))
IF CODE=""
QUIT
Begin DoDot:2
+40 IF $DATA(^TMP($JOB,"CUREXP",TYPE,CODE))
KILL ^TMP($JOB,"CUREXP",TYPE,CODE),^TMP($JOB,"NEWEXP",TYPE,CODE)
End DoDot:2
End DoDot:1
+41 IF $DATA(^TMP($JOB,"NEWEXP"))
Begin DoDot:1
+42 SET EXPOK=0
+43 WRITE !!,"The following codes are missing from the expansion:"
+44 DO OUTPUT("NEWEXP")
End DoDot:1
+45 IF $DATA(^TMP($JOB,"CUREXP"))
Begin DoDot:1
+46 SET EXPOK=0
+47 WRITE !!,"The following codes are in the expansion and they should not be:"
+48 DO OUTPUT("CUREXP")
End DoDot:1
+49 IF EXPOK
WRITE !,"The expansion is correct."
+50 KILL ^TMP($JOB,"CUREXP"),^TMP($JOB,"NEWEXP")
+51 QUIT
+52 ;
+53 ;====================================================
ICD0(TAXIEN,LOW,HIGH,SUB) ;Build the list of internal entries for ICD0
+1 ;(File 80.1). Use of ICDAPIU: DBIA #3991
+2 NEW CODE,IEN,TEMP
+3 SET CODE=LOW
+4 FOR
IF (CODE]HIGH)!(CODE="")
QUIT
Begin DoDot:1
+5 SET TEMP=$$STATCHK^ICDAPIU(CODE,"")
+6 SET IEN=$PIECE(TEMP,U,2)
+7 IF IEN'=-1
IF '$DATA(^TMP($JOB,SUB,"ICD 0",IEN))
Begin DoDot:2
+8 SET ^TMP($JOB,SUB,"ICD 0",IEN)=""
End DoDot:2
+9 SET CODE=$$NEXT^ICDAPIU(CODE)
End DoDot:1
+10 QUIT
+11 ;
+12 ;====================================================
ICD9(TAXIEN,LOW,HIGH,SUB) ;Build the list of internal entries for ICD9
+1 ;(File 80). Use of ICDAPIU: DBIA #3991
+2 NEW CODE,IEN,TEMP
+3 SET CODE=LOW
+4 FOR
IF (CODE]HIGH)!(CODE="")
QUIT
Begin DoDot:1
+5 SET TEMP=$$STATCHK^ICDAPIU(CODE,"")
+6 SET IEN=$PIECE(TEMP,U,2)
+7 IF IEN'=-1
IF '$DATA(^TMP(SUB,"ICD 9",IEN))
Begin DoDot:2
+8 SET ^TMP($JOB,SUB,"ICD 9",IEN)=""
End DoDot:2
+9 SET CODE=$$NEXT^ICDAPIU(CODE)
End DoDot:1
+10 QUIT
+11 ;
+12 ;====================================================
ICPT(TAXIEN,LOW,HIGH,SUB) ;Build the list of internal entries
+1 ;for ICPT (File 81). Use of ICDAPIU: DBIA #3991
+2 NEW CODE,IEN,RADIEN,TEMP
+3 SET CODE=LOW
+4 FOR
IF (CODE]HIGH)!(CODE="")
QUIT
Begin DoDot:1
+5 SET TEMP=$$STATCHK^ICPTAPIU(CODE,"")
+6 SET IEN=$PIECE(TEMP,U,2)
+7 IF IEN'=-1
IF '$DATA(^TMP($JOB,SUB,"CPT",IEN))
Begin DoDot:2
+8 SET ^TMP($JOB,SUB,"CPT",IEN)=""
End DoDot:2
+9 SET CODE=$$NEXT^ICPTAPIU(CODE)
End DoDot:1
+10 QUIT
+11 ;
+12 ;====================================================
OUTPUT(SUB) ;Output codes that are left.
+1 ;References to ICDCODE DBIA #3990.
+2 ;References to ICPTCOD DBIA #1995.
+3 NEW IEN,LIST,NUM,TEMP,TYPE
+4 KILL LIST
+5 SET TYPE=""
+6 FOR
SET TYPE=$ORDER(^TMP($JOB,SUB,TYPE))
IF TYPE=""
QUIT
Begin DoDot:1
+7 WRITE !," ",TYPE," codes:"
+8 SET IEN=0
+9 FOR
SET IEN=$ORDER(^TMP($JOB,SUB,TYPE,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+10 IF TYPE="CPT"
Begin DoDot:3
+11 SET CODE=$$CPT^ICPTCOD(IEN,DT)
+12 SET TEMP=$PIECE(CODE,U,3)
End DoDot:3
+13 IF TYPE="ICD 0"
Begin DoDot:3
+14 SET CODE=$$ICDOP^ICDCODE(IEN,DT)
+15 SET TEMP=$PIECE(CODE,U,5)
End DoDot:3
+16 IF TYPE="ICD 9"
Begin DoDot:3
+17 SET CODE=$$ICDDX^ICDCODE(IEN,DT)
+18 SET TEMP=$PIECE(CODE,U,4)
End DoDot:3
+19 SET TEMP=$EXTRACT(TEMP,1,30)
+20 SET LIST($PIECE(CODE,U,2)_" ")=$$LJ^XLFSTR(TEMP,30)_" (IEN="_IEN_")"
End DoDot:2
+21 SET CODE=""
SET NUM=0
+22 FOR
SET CODE=$ORDER(LIST(CODE))
IF CODE=""
QUIT
Begin DoDot:2
+23 SET NUM=NUM+1
+24 WRITE !,$$RJ^XLFSTR(NUM,4)," ",$$LJ^XLFSTR(CODE,9),LIST(CODE)
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
