APCLTAXL.m

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

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

 ;; ;

ICPTADD ;EP

 S ATXFLG=""

 I APCLFILE=81 S APCLGBL="^ICPT("

 S APCLX=APCLTAXI

 D BUILD,^APCLTAXM

 D EDIT

 K ATXFLG,APCLX,APCLL,ATX,APCLTBLE

 Q

 ;

BUILD ;BUILD APCLTBLE FOR ROUTINE ATXCODE

 S APCLCODE=0 F  S APCLCODE=$O(^ATXAX(APCLX,21,"AA",APCLCODE)) Q:APCLCODE=""  S APCLTBLE(APCLCODE)=$O(^(APCLCODE,""))

 Q

ENTER ;

 S APCL=0 F  S APCL=$O(APCLTBLE(APCL)) Q:APCL=""  S APCL("X")=$E(APCL,1,($L(APCL)-1)) D CALLDIE I $D(Y) S APCLSTP=1 Q

 W !!,"Done!"

 Q

 ;

CALLDIE ;

 S APCLHI=$E(APCLTBLE(APCL),1,($L(APCLTBLE(APCL))-1)),DIE="^ATXAX(",DR="2101///"_APCL("X")_" ",DA=APCLX,DR(2,9002226.02101)=".02////"_APCLHI_" " D ^DIE I $D(Y)

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

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

 K DIE,DR,DA

 Q

 ;

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

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

 D ENTER

 Q

 ;

EOJ1 ;

 K APCLHI

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

 Q

 ;

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

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

 +2       ;; ;

ICPTADD   ;EP

 +1        SET ATXFLG=""

 +2        IF APCLFILE=81

               SET APCLGBL="^ICPT("

 +3        SET APCLX=APCLTAXI

 +4        DO BUILD

           DO ^APCLTAXM

 +5        DO EDIT

 +6        KILL ATXFLG,APCLX,APCLL,ATX,APCLTBLE

 +7        QUIT 

 +8       ;

BUILD     ;BUILD APCLTBLE FOR ROUTINE ATXCODE

 +1        SET APCLCODE=0

           FOR 

               SET APCLCODE=$ORDER(^ATXAX(APCLX,21,"AA",APCLCODE))

               IF APCLCODE=""

                   QUIT 

               SET APCLTBLE(APCLCODE)=$ORDER(^(APCLCODE,""))

 +2        QUIT 

ENTER     ;

 +1        SET APCL=0

           FOR 

               SET APCL=$ORDER(APCLTBLE(APCL))

               IF APCL=""

                   QUIT 

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

               DO CALLDIE

               IF $DATA(Y)

                   SET APCLSTP=1

                   QUIT 

 +2        WRITE !!,"Done!"

 +3        QUIT 

 +4       ;

CALLDIE   ;

 +1        SET APCLHI=$EXTRACT(APCLTBLE(APCL),1,($LENGTH(APCLTBLE(APCL))-1))

           SET DIE="^ATXAX("

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

           SET DA=APCLX

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

           DO ^DIE

           IF $DATA(Y)

 +2       IF '$TEST

               IF '$DATA(ZTQUEUED)

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

                       WRITE "."

 +3        IF $DATA(Y)

               IF '$DATA(ZTQUEUED)

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

           FOR 

               SET APCL=$ORDER(^ATXAX(APCLX,21,APCL))

               IF APCL'=+APCL

                   QUIT 

               SET DA(1)=APCLX

               SET DA=APCL

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

               DO ^DIK

               KILL DIK,DA

 +2        DO ENTER

 +3        QUIT 

 +4       ;

EOJ1      ;

 +1        KILL APCLHI

 +2        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +3        QUIT 

 +4       ;