APCHTAXL.m

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

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;; ;

ICPTADD ;EP

 S ATXFLG=""

 I APCHFILE=81 S APCHGBL="^ICPT("

 S APCHX=APCHTAXI

 D BUILD,^APCHTAXM

 D EDIT

 K ATXFLG,APCHX,APCHL,ATX,APCHTBLE

 Q

 ;

BUILD ;BUILD APCHTBLE FOR ROUTINE ATXCODE

 S APCHCODE=0 F  S APCHCODE=$O(^ATXAX(APCHX,21,"AA",APCHCODE)) Q:APCHCODE=""  S APCHTBLE(APCHCODE)=$O(^(APCHCODE,""))

 Q

ENTER ;

 S APCH=0 F  S APCH=$O(APCHTBLE(APCH)) Q:APCH=""  S APCH("X")=$E(APCH,1,($L(APCH)-1)) D CALLDIE I $D(Y) S APCHSTP=1 Q

 W !!,"Done!"

 Q

 ;

CALLDIE ;

 S APCHHI=$E(APCHTBLE(APCH),1,($L(APCHTBLE(APCH))-1)),DIE="^ATXAX(",DR="2101///"_APCH("X")_" ",DA=APCHX,DR(2,9002226.02101)=".02////"_APCHHI_" " D ^DIE I $D(Y)

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

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

 K DIE,DR,DA

 Q

 ;

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

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

 D ENTER

 Q

 ;

EOJ1 ;

 K APCHHI

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

 Q

 ;

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

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;; ;

ICPTADD   ;EP

 +1        SET ATXFLG=""

 +2        IF APCHFILE=81

               SET APCHGBL="^ICPT("

 +3        SET APCHX=APCHTAXI

 +4        DO BUILD

           DO ^APCHTAXM

 +5        DO EDIT

 +6        KILL ATXFLG,APCHX,APCHL,ATX,APCHTBLE

 +7        QUIT 

 +8       ;

BUILD     ;BUILD APCHTBLE FOR ROUTINE ATXCODE

 +1        SET APCHCODE=0

           FOR 

               SET APCHCODE=$ORDER(^ATXAX(APCHX,21,"AA",APCHCODE))

               IF APCHCODE=""

                   QUIT 

               SET APCHTBLE(APCHCODE)=$ORDER(^(APCHCODE,""))

 +2        QUIT 

ENTER     ;

 +1        SET APCH=0

           FOR 

               SET APCH=$ORDER(APCHTBLE(APCH))

               IF APCH=""

                   QUIT 

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

               DO CALLDIE

               IF $DATA(Y)

                   SET APCHSTP=1

                   QUIT 

 +2        WRITE !!,"Done!"

 +3        QUIT 

 +4       ;

CALLDIE   ;

 +1        SET APCHHI=$EXTRACT(APCHTBLE(APCH),1,($LENGTH(APCHTBLE(APCH))-1))

           SET DIE="^ATXAX("

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

           SET DA=APCHX

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

           DO ^DIE

           IF $DATA(Y)

 +2       IF '$TEST

               IF '$DATA(ZTQUEUED)

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

                       WRITE "."

 +3        IF $DATA(Y)

               IF '$DATA(ZTQUEUED)

                   IF $DATA(APCH("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 APCH=0

           FOR 

               SET APCH=$ORDER(^ATXAX(APCHX,21,APCH))

               IF APCH'=+APCH

                   QUIT 

               SET DA(1)=APCHX

               SET DA=APCH

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

               DO ^DIK

               KILL DIK,DA

 +2        DO ENTER

 +3        QUIT 

 +4       ;

EOJ1      ;

 +1        KILL APCHHI

 +2        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +3        QUIT 

 +4       ;