ATXMOD.m

ATXMOD ; IHS/OHPRD/TMJ -  ICD9 TAXONOMY FIELD ; 

 ;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48

 ;

ZTM ;ENTRY POINT FOR TASKMAN

 D INIT

 D DFNS

 D NEWTOLD

 D OLDTONEW

 I $D(ZTQUEUED) S ZTREQ="@"

 D EOJ

 Q

 ;

INIT ;

 I '$D(^ATXPAT(ATXX,0))#2!('$P(^ATXAX(ATXX,0),U,6)) S ATXPRO="" ;PT TAXONOMY FILE NOT UPDATED

 K ^TMP($J,"ATXNEW",ATXX)

 Q

 ;

DFNS ;GET LO AND HIGH DFNS FOR THIS TAXONOMY

 S ATXSS=0 F ATXL=0:0 S ATXSS=$O(^ATXAX(ATXX,21,ATXSS)) Q:ATXSS'=+ATXSS  S ATXLOV=$P(^(ATXSS,0),U)_" ",ATXHIV=$P(^(0),U,2)_" " D GETVAL

 Q

 ;

GETVAL ;GET RANGE OF DFNS

 S ^TMP($J,"ATXNEW",ATXX,$O(^ICD9("BA",ATXLOV,"")))=""

 Q:'ATXHIV!(ATXHIV=ATXLOV)

 F  S ATXLOV=$O(^ICD9("BA",ATXLOV)) Q:ATXLOV](ATXHIV)!(ATXLOV="")  S ATXDFN=$O(^ICD9("BA",ATXLOV,"")) S ^TMP($J,"ATXNEW",ATXX,ATXDFN)=""

 Q

 ;

NEWTOLD ;SEE WHAT CODES ADDED TO TAXONOMY

 S ATXD=0 F L=0:0 S ATXD=$O(^TMP($J,"ATXNEW",ATXX,ATXD)) Q:ATXD'=+ATXD  I '$D(^TMP($J,"ATXEMP",ATXX,ATXD)) D DIEADD

 Q

 ;

OLDTONEW ;SEE WHAT CODES DELETED FROM TAXONOMY

 S ATXD=0 F L=0:0 S ATXD=$O(^TMP($J,"ATXEMP",ATXX,ATXD)) Q:ATXD'=+ATXD  I '$D(^TMP($J,"ATXNEW",ATXX,ATXD)) D DIEDELT

 Q

 ;

DIEADD ;CALL TO DIE TO ENTER TAXONOMY TO NEWLY ENTERED CODES INTO TAXONOMY FILE

 S DIE="^ICD9(",DR="9999999.41///"_"`"_ATXX,DA=ATXD D ^DIE K DIE

 Q

 ;

DIEDELT ;CALL TO DIE TO DELETE TAXONOMY FROM DELETED CODES OUT OF TAXONOMY FILE

 S DIE="^ICD9(",DR="9999999.41///"_"`"_ATXX,DR(2,80.999999941)=".01///@",DA=ATXD D ^DIE K DIE

 Q

 ;

EOJ ;

 K ^TMP($J,"ATXNEW",ATXX),^TMP($J,"ATXEMP",ATXX),^TMP($J,"ATXTAX",ATXX)

 K ATXLOV,ATXHIVO,ATXHI,ATXDFN,ATXD,ATXWT,ATXDEL,ATXPRO,ATXX,ATXX,ATXSS

 Q

 ;

ATXMOD    ; IHS/OHPRD/TMJ -  ICD9 TAXONOMY FIELD ; 

 +1       ;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48

 +2       ;

ZTM       ;ENTRY POINT FOR TASKMAN

 +1        DO INIT

 +2        DO DFNS

 +3        DO NEWTOLD

 +4        DO OLDTONEW

 +5        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +6        DO EOJ

 +7        QUIT 

 +8       ;

INIT      ;

 +1       ;PT TAXONOMY FILE NOT UPDATED

           IF '$DATA(^ATXPAT(ATXX,0))#2!('$PIECE(^ATXAX(ATXX,0),U,6))

               SET ATXPRO=""

 +2        KILL ^TMP($JOB,"ATXNEW",ATXX)

 +3        QUIT 

 +4       ;

DFNS      ;GET LO AND HIGH DFNS FOR THIS TAXONOMY

 +1        SET ATXSS=0

           FOR ATXL=0:0

               SET ATXSS=$ORDER(^ATXAX(ATXX,21,ATXSS))

               IF ATXSS'=+ATXSS

                   QUIT 

               SET ATXLOV=$PIECE(^(ATXSS,0),U)_" "

               SET ATXHIV=$PIECE(^(0),U,2)_" "

               DO GETVAL

 +2        QUIT 

 +3       ;

GETVAL    ;GET RANGE OF DFNS

 +1        SET ^TMP($JOB,"ATXNEW",ATXX,$ORDER(^ICD9("BA",ATXLOV,"")))=""

 +2        IF 'ATXHIV!(ATXHIV=ATXLOV)

               QUIT 

 +3        FOR 

               SET ATXLOV=$ORDER(^ICD9("BA",ATXLOV))

               IF ATXLOV](ATXHIV)!(ATXLOV="")

                   QUIT 

               SET ATXDFN=$ORDER(^ICD9("BA",ATXLOV,""))

               SET ^TMP($JOB,"ATXNEW",ATXX,ATXDFN)=""

 +4        QUIT 

 +5       ;

NEWTOLD   ;SEE WHAT CODES ADDED TO TAXONOMY

 +1        SET ATXD=0

           FOR L=0:0

               SET ATXD=$ORDER(^TMP($JOB,"ATXNEW",ATXX,ATXD))

               IF ATXD'=+ATXD

                   QUIT 

               IF '$DATA(^TMP($JOB,"ATXEMP",ATXX,ATXD))

                   DO DIEADD

 +2        QUIT 

 +3       ;

OLDTONEW  ;SEE WHAT CODES DELETED FROM TAXONOMY

 +1        SET ATXD=0

           FOR L=0:0

               SET ATXD=$ORDER(^TMP($JOB,"ATXEMP",ATXX,ATXD))

               IF ATXD'=+ATXD

                   QUIT 

               IF '$DATA(^TMP($JOB,"ATXNEW",ATXX,ATXD))

                   DO DIEDELT

 +2        QUIT 

 +3       ;

DIEADD    ;CALL TO DIE TO ENTER TAXONOMY TO NEWLY ENTERED CODES INTO TAXONOMY FILE

 +1        SET DIE="^ICD9("

           SET DR="9999999.41///"_"`"_ATXX

           SET DA=ATXD

           DO ^DIE

           KILL DIE

 +2        QUIT 

 +3       ;

DIEDELT   ;CALL TO DIE TO DELETE TAXONOMY FROM DELETED CODES OUT OF TAXONOMY FILE

 +1        SET DIE="^ICD9("

           SET DR="9999999.41///"_"`"_ATXX

           SET DR(2,80.999999941)=".01///@"

           SET DA=ATXD

           DO ^DIE

           KILL DIE

 +2        QUIT 

 +3       ;

EOJ       ;

 +1        KILL ^TMP($JOB,"ATXNEW",ATXX),^TMP($JOB,"ATXEMP",ATXX),^TMP($JOB,"ATXTAX",ATXX)

 +2        KILL ATXLOV,ATXHIVO,ATXHI,ATXDFN,ATXD,ATXWT,ATXDEL,ATXPRO,ATXX,ATXX,ATXSS

 +3        QUIT 

 +4       ;