ATXTAXL.m

ATXTAXL ; IHS/CMI/LAB - DISPLAY IND LISTS ;

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

 ;; ;

ICPTADD ;EP

 S ATXFLG=""

 I ATXFILE=81 S ATXGBL="^ICPT("

 S ATXX=ATXTAXI

 D BUILD,^ATXTAXM

 D EDIT

 K ATXFLG,ATXX,ATXL,ATX,ATXTBLE

 Q

 ;

BUILD ;BUILD ATXTBLE FOR ROUTINE ATXCODE

 S ATXCODE=0 F  S ATXCODE=$O(^ATXAX(ATXX,21,"AA",ATXCODE)) Q:ATXCODE=""  S ATXTBLE(ATXCODE)=$O(^(ATXCODE,""))

 Q

ENTER ;

 S ATX=0 F  S ATX=$O(ATXTBLE(ATX)) Q:ATX=""  S ATX("X")=$E(ATX,1,($L(ATX)-1)) D CALLDIE I $D(Y) S ATXSTP=1 Q

 W !!,"Done!"

 Q

 ;

CALLDIE ;

 S ATXHI=$E(ATXTBLE(ATX),1,($L(ATXTBLE(ATX))-1)),DIE="^ATXAX(",DR="2101///"_ATX("X")_" ",DA=ATXX,DR(2,9002226.02101)=".02////"_ATXHI_" " D ^DIE I $D(Y)

 E  I '$D(ZTQUEUED),$D(ATX("NOT TAX")) W "."

 I $D(Y),'$D(ZTQUEUED),$D(ATX("NOT TAX")) W !!,"ERROR ENCOUNTERED - REENTER RANGES",!

 K DIE,DR,DA

 Q

 ;

EDIT ;DELETE CODES IN TAXONOMY FILE, THEN ENTER NEW RANGES

 S ATX=0 F  S ATX=$O(^ATXAX(ATXX,21,ATX)) Q:ATX'=+ATX  S DA(1)=ATXX,DA=ATX,DIK="^ATXAX("_DA(1)_",21," D ^DIK K DIK,DA

 D ENTER

 Q

 ;

EOJ1 ;

 K ATXHI

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

 Q

 ;

ATXTAXL   ; IHS/CMI/LAB - DISPLAY IND LISTS ;

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

 +2       ;; ;

ICPTADD   ;EP

 +1        SET ATXFLG=""

 +2        IF ATXFILE=81

               SET ATXGBL="^ICPT("

 +3        SET ATXX=ATXTAXI

 +4        DO BUILD

           DO ^ATXTAXM

 +5        DO EDIT

 +6        KILL ATXFLG,ATXX,ATXL,ATX,ATXTBLE

 +7        QUIT 

 +8       ;

BUILD     ;BUILD ATXTBLE FOR ROUTINE ATXCODE

 +1        SET ATXCODE=0

           FOR 

               SET ATXCODE=$ORDER(^ATXAX(ATXX,21,"AA",ATXCODE))

               IF ATXCODE=""

                   QUIT 

               SET ATXTBLE(ATXCODE)=$ORDER(^(ATXCODE,""))

 +2        QUIT 

ENTER     ;

 +1        SET ATX=0

           FOR 

               SET ATX=$ORDER(ATXTBLE(ATX))

               IF ATX=""

                   QUIT 

               SET ATX("X")=$EXTRACT(ATX,1,($LENGTH(ATX)-1))

               DO CALLDIE

               IF $DATA(Y)

                   SET ATXSTP=1

                   QUIT 

 +2        WRITE !!,"Done!"

 +3        QUIT 

 +4       ;

CALLDIE   ;

 +1        SET ATXHI=$EXTRACT(ATXTBLE(ATX),1,($LENGTH(ATXTBLE(ATX))-1))

           SET DIE="^ATXAX("

           SET DR="2101///"_ATX("X")_" "

           SET DA=ATXX

           SET DR(2,9002226.02101)=".02////"_ATXHI_" "

           DO ^DIE

           IF $DATA(Y)

 +2       IF '$TEST

               IF '$DATA(ZTQUEUED)

                   IF $DATA(ATX("NOT TAX"))

                       WRITE "."

 +3        IF $DATA(Y)

               IF '$DATA(ZTQUEUED)

                   IF $DATA(ATX("NOT TAX"))

                       WRITE !!,"ERROR ENCOUNTERED - REENTER RANGES",!

 +4        KILL DIE,DR,DA

 +5        QUIT 

 +6       ;

EDIT      ;DELETE CODES IN TAXONOMY FILE, THEN ENTER NEW RANGES

 +1        SET ATX=0

           FOR 

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

               IF ATX'=+ATX

                   QUIT 

               SET DA(1)=ATXX

               SET DA=ATX

               SET DIK="^ATXAX("_DA(1)_",21,"

               DO ^DIK

               KILL DIK,DA

 +2        DO ENTER

 +3        QUIT 

 +4       ;

EOJ1      ;

 +1        KILL ATXHI

 +2        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +3        QUIT 

 +4       ;