Routine: APCLPOS5

APCLPOS5 ; IHS/OHPRD/TMJ - Non DX/PX Taxonomy Fix ;

 ;;3.0;IHS PCC REPORTS;;FEB 05, 1997

START ;

 S ATXFLG=1

 D TOBACCO,TBHLTH,DMEDUC,DMADA

TOBACCO ;add tobacco health factor taxonomy

 W !,"Creating Tobacco Health factors taxonomy... "

 S APCLDA=0 F  S APCLDA=$O(^ATXAX("B","DM AUDIT TOBACCO HLTH FACTORS",APCLDA)) Q:APCLDA=""  I APCLDA S DA=APCLDA S DIK="^ATXAX(" D ^DIK K DA,DIK

 S X="DM AUDIT TOBACCO HLTH FACTORS",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I

 I Y=-1 W !!,"ERROR IN CREATING DM AUDIT TOBACCO HLTH FACTORS TAX" Q

 S APCLTX=+Y,$P(^ATXAX(APCLTX,0),U,2)="DM AUDIT TOBACCO HLTH FACTORS",$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=78,$P(^(0),U,13)=0,$P(^(0),U,15)=9999999.64,^ATXAX(APCLTX,21,0)="^9002226.02101A^0^0"

 S APCLTEXT="TOB" F APCLX=1:1:5 S X=$P($T(@APCLTEXT+APCLX),";;",2),DIC="^AUTTHF(",DIC(0)="M" D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0 I $P(Y,U)>0 D

 .S ^ATXAX(APCLTX,21,APCLX,0)=+Y,$P(^ATXAX(APCLTX,21,0),U,3)=APCLX,$P(^(0),U,4)=APCLX,^ATXAX(APCLTX,21,"AA",+Y,APCLX)=""

.Q

 S DA=APCLTX,DIK="^ATXAX(" D IX1^DIK

DMEDUC ;

 W !,"Creating Education topics taxonomy..."

 S APCLDA=0 F  S APCLDA=$O(^ATXAX("B","DM AUDIT DIABETES EDUC TOPICS",APCLDA)) Q:APCLDA=""  I APCLDA S DA=APCLDA S DIK="^ATXAX(" D ^DIK K DA,DIK

 S X="DM AUDIT DIABETES EDUC TOPICS",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I

 I Y=-1 W !!,"ERROR IN CREATING DM AUDIT DIABETES EDUC TOPICS TAX" Q

 S APCLTX=+Y,$P(^ATXAX(APCLTX,0),U,2)="DM AUDIT DIABETES EDUC TOPICS",$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=280,$P(^(0),U,13)=0,$P(^(0),U,15)=9999999.09,^ATXAX(APCLTX,21,0)="^9002226.02101A^0^0"

 S APCLTEXT="EDUC" F APCLX=1:1:10 S X=$P($T(@APCLTEXT+APCLX),";;",2),DIC="^AUTTEDT(",DIC(0)="M" D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0 I $P(Y,U)>0 D

 .S ^ATXAX(APCLTX,21,APCLX,0)=+Y,$P(^ATXAX(APCLTX,21,0),U,3)=APCLX,$P(^(0),U,4)=APCLX,^ATXAX(APCLTX,21,"AA",+Y,APCLX)=""

.Q

 S DA=APCLTX,DIK="^ATXAX(" D IX1^DIK

DMADA ;

 W !,"Creating DM ADA Codes Taxonomy..."

 S APCLDA=0 F  S APCLDA=$O(^ATXAX("B","DM AUDIT DENTAL EXAM ADA CODES",APCLDA)) Q:APCLDA=""  I APCLDA S DA=APCLDA S DIK="^ATXAX(" D ^DIK K DA,DIK

 S X="DM AUDIT DENTAL EXAM ADA CODES",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I

 I Y=-1 W !!,"ERROR IN CREATING DM AUDIT DENTAL EXAM ADA CODES TAX" Q

 S APCLTX=+Y,$P(^ATXAX(APCLTX,0),U,2)="DM AUDIT DENTAL EXAM ADA CODES",$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=174,$P(^(0),U,13)=0,$P(^(0),U,15)=9999999.31,^ATXAX(APCLTX,21,0)="^9002226.02101A^0^0"

 S APCLTEXT="ADA" F APCLX=1:1:2 S X=$P($T(@APCLTEXT+APCLX),";;",2),DIC="^AUTTADA(",DIC(0)="M" D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0 I $P(Y,U)>0 D

 .S ^ATXAX(APCLTX,21,APCLX,0)=+Y,$P(^ATXAX(APCLTX,21,0),U,3)=APCLX,$P(^(0),U,4)=APCLX,^ATXAX(APCLTX,21,"AA",+Y,APCLX)=""

.Q

 S DA=APCLTX,DIK="^ATXAX(" D IX1^DIK

TBHLTH ;tb health factors taxonomy

 W !,"Creating TB HF Taxonomy... "

 S APCLDA=0 F  S APCLDA=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",APCLDA)) Q:APCLDA=""  I APCLDA S DA=APCLDA S DIK="^ATXAX(" D ^DIK K DA,DIK

 S X="DM AUDIT TB HEALTH FACTORS",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DIADD,DLAYGO,DA,DR,DO,D0

 I Y=-1 W !!,"ERROR IN CREATING DM AUDIT TB HLTH FACTORS TAX" Q

 S APCLTX=+Y,$P(^ATXAX(APCLTX,0),U,2)="TB TX STATUS HLTH FACTORS",$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=78,$P(^(0),U,13)=0,$P(^(0),U,15)=9999999.64

 S ^ATXAX(APCLTX,21,0)="^9002226.02101A^0^0"

 S APCLTEXT="TBHF" F APCLX=1:1:4 S X=$P($T(@APCLTEXT+APCLX),";;",2),DIC="^AUTTHF(",DIC(0)="M" D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0 I $P(Y,U)>0 D

 .S ^ATXAX(APCLTX,21,APCLX,0)=+Y,$P(^ATXAX(APCLTX,21,0),U,3)=APCLX,$P(^(0),U,4)=APCLX,^ATXAX(APCLTX,21,"AA",+Y,APCLX)=""

.Q

 S DA=APCLTX,DIK="^ATXAX(" D IX1^DIK

TBHF ;

 ;;TB - TX UNTREATED

 ;;TB - TX INCOMPLETE

 ;;TB - TX COMPLETE

 ;;TB - TX UNKNOWN

TOB ;

 ;;NON-TOBACCO USER

 ;;CURRENT SMOKER

 ;;CURRENT SMOKELESS

 ;;PREVIOUS SMOKER

 ;;PREVIOUS SMOKELESS

EDUC ;

 ;;DM-COMPLICATIONS

 ;;DM-DIET

 ;;DM-DISEASE PROCESS

 ;;DM-EXERCISE

 ;;DM-FOLLOW UP

 ;;DM-FOOT CARE

 ;;DM-GENERAL INFORMATION

 ;;DM-LIFESTYLE ADAPTATIONS

 ;;DM-MEDICATIONS

 ;;DM-NUTRITION

ADA ;

 ;;0110

 ;;0120

 ;;0150

 ;;9321

 ;;9320

APCLPOS5  ; IHS/OHPRD/TMJ - Non DX/PX Taxonomy Fix ;

 +1       ;;3.0;IHS PCC REPORTS;;FEB 05, 1997

 +2       ;

START     ;

 +1        SET ATXFLG=1

 +2        DO TOBACCO

           DO TBHLTH

           DO DMEDUC

           DO DMADA

 +3        QUIT

TOBACCO   ;add tobacco health factor taxonomy

 +1        WRITE !,"Creating Tobacco Health factors taxonomy... "

 +2        SET APCLDA=0

FOR

               SET APCLDA=$ORDER(^ATXAX("B","DM AUDIT TOBACCO HLTH FACTORS",APCLDA))

               IF APCLDA=""

                   QUIT

               IF APCLDA

                   SET DA=APCLDA

                   SET DIK="^ATXAX("

                   DO ^DIK

                   KILL DA,DIK

 +3        SET X="DM AUDIT TOBACCO HLTH FACTORS"

           SET DIC="^ATXAX("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9002226

           DO ^DIC

           KILL DIC,DA,DIADD,DLAYGO,I

 +4        IF Y=-1

               WRITE !!,"ERROR IN CREATING DM AUDIT TOBACCO HLTH FACTORS TAX"

               QUIT

 +5        SET APCLTX=+Y

           SET $PIECE(^ATXAX(APCLTX,0),U,2)="DM AUDIT TOBACCO HLTH FACTORS"

           SET $PIECE(^(0),U,5)=DUZ

           SET $PIECE(^(0),U,8)=0

           SET $PIECE(^(0),U,9)=DT

           SET $PIECE(^(0),U,12)=78

           SET $PIECE(^(0),U,13)=0

           SET $PIECE(^(0),U,15)=9999999.64

           SET ^ATXAX(APCLTX,21,0)="^9002226.02101A^0^0"

 +6        SET APCLTEXT="TOB"

           FOR APCLX=1:1:5

               SET X=$PIECE($TEXT(@APCLTEXT+APCLX),";;",2)

               SET DIC="^AUTTHF("

               SET DIC(0)="M"

               DO ^DIC

               KILL DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0

               IF $PIECE(Y,U)>0

                   Begin DoDot:1

 +7                    SET ^ATXAX(APCLTX,21,APCLX,0)=+Y

                       SET $PIECE(^ATXAX(APCLTX,21,0),U,3)=APCLX

                       SET $PIECE(^(0),U,4)=APCLX

                       SET ^ATXAX(APCLTX,21,"AA",+Y,APCLX)=""

 +8                    QUIT

                   End DoDot:1

 +9        SET DA=APCLTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +10       QUIT

DMEDUC    ;

 +1        WRITE !,"Creating Education topics taxonomy..."

 +2        SET APCLDA=0

FOR

               SET APCLDA=$ORDER(^ATXAX("B","DM AUDIT DIABETES EDUC TOPICS",APCLDA))

               IF APCLDA=""

                   QUIT

               IF APCLDA

                   SET DA=APCLDA

                   SET DIK="^ATXAX("

                   DO ^DIK

                   KILL DA,DIK

 +3        SET X="DM AUDIT DIABETES EDUC TOPICS"

           SET DIC="^ATXAX("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9002226

           DO ^DIC

           KILL DIC,DA,DIADD,DLAYGO,I

 +4        IF Y=-1

               WRITE !!,"ERROR IN CREATING DM AUDIT DIABETES EDUC TOPICS TAX"

               QUIT

 +5        SET APCLTX=+Y

           SET $PIECE(^ATXAX(APCLTX,0),U,2)="DM AUDIT DIABETES EDUC TOPICS"

           SET $PIECE(^(0),U,5)=DUZ

           SET $PIECE(^(0),U,8)=0

           SET $PIECE(^(0),U,9)=DT

           SET $PIECE(^(0),U,12)=280

           SET $PIECE(^(0),U,13)=0

           SET $PIECE(^(0),U,15)=9999999.09

           SET ^ATXAX(APCLTX,21,0)="^9002226.02101A^0^0"

 +6        SET APCLTEXT="EDUC"

           FOR APCLX=1:1:10

               SET X=$PIECE($TEXT(@APCLTEXT+APCLX),";;",2)

               SET DIC="^AUTTEDT("

               SET DIC(0)="M"

               DO ^DIC

               KILL DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0

               IF $PIECE(Y,U)>0

                   Begin DoDot:1

 +7                    SET ^ATXAX(APCLTX,21,APCLX,0)=+Y

                       SET $PIECE(^ATXAX(APCLTX,21,0),U,3)=APCLX

                       SET $PIECE(^(0),U,4)=APCLX

                       SET ^ATXAX(APCLTX,21,"AA",+Y,APCLX)=""

 +8                    QUIT

                   End DoDot:1

 +9        SET DA=APCLTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +10       QUIT

DMADA     ;

 +1        WRITE !,"Creating DM ADA Codes Taxonomy..."

 +2        SET APCLDA=0

FOR

               SET APCLDA=$ORDER(^ATXAX("B","DM AUDIT DENTAL EXAM ADA CODES",APCLDA))

               IF APCLDA=""

                   QUIT

               IF APCLDA

                   SET DA=APCLDA

                   SET DIK="^ATXAX("

                   DO ^DIK

                   KILL DA,DIK

 +3        SET X="DM AUDIT DENTAL EXAM ADA CODES"

           SET DIC="^ATXAX("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9002226

           DO ^DIC

           KILL DIC,DA,DIADD,DLAYGO,I

 +4        IF Y=-1

               WRITE !!,"ERROR IN CREATING DM AUDIT DENTAL EXAM ADA CODES TAX"

               QUIT

 +5        SET APCLTX=+Y

           SET $PIECE(^ATXAX(APCLTX,0),U,2)="DM AUDIT DENTAL EXAM ADA CODES"

           SET $PIECE(^(0),U,5)=DUZ

           SET $PIECE(^(0),U,8)=0

           SET $PIECE(^(0),U,9)=DT

           SET $PIECE(^(0),U,12)=174

           SET $PIECE(^(0),U,13)=0

           SET $PIECE(^(0),U,15)=9999999.31

           SET ^ATXAX(APCLTX,21,0)="^9002226.02101A^0^0"

 +6        SET APCLTEXT="ADA"

           FOR APCLX=1:1:2

               SET X=$PIECE($TEXT(@APCLTEXT+APCLX),";;",2)

               SET DIC="^AUTTADA("

               SET DIC(0)="M"

               DO ^DIC

               KILL DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0

               IF $PIECE(Y,U)>0

                   Begin DoDot:1

 +7                    SET ^ATXAX(APCLTX,21,APCLX,0)=+Y

                       SET $PIECE(^ATXAX(APCLTX,21,0),U,3)=APCLX

                       SET $PIECE(^(0),U,4)=APCLX

                       SET ^ATXAX(APCLTX,21,"AA",+Y,APCLX)=""

 +8                    QUIT

                   End DoDot:1

 +9        SET DA=APCLTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +10       QUIT

TBHLTH    ;tb health factors taxonomy

 +1        WRITE !,"Creating TB HF Taxonomy... "

 +2        SET APCLDA=0

FOR

               SET APCLDA=$ORDER(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",APCLDA))

               IF APCLDA=""

                   QUIT

               IF APCLDA

                   SET DA=APCLDA

                   SET DIK="^ATXAX("

                   DO ^DIK

                   KILL DA,DIK

 +3        SET X="DM AUDIT TB HEALTH FACTORS"

           SET DIC="^ATXAX("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9002226

           DO ^DIC

           KILL DIC,DIADD,DLAYGO,DA,DR,DO,D0

 +4        IF Y=-1

               WRITE !!,"ERROR IN CREATING DM AUDIT TB HLTH FACTORS TAX"

               QUIT

 +5        SET APCLTX=+Y

           SET $PIECE(^ATXAX(APCLTX,0),U,2)="TB TX STATUS HLTH FACTORS"

           SET $PIECE(^(0),U,5)=DUZ

           SET $PIECE(^(0),U,8)=0

           SET $PIECE(^(0),U,9)=DT

           SET $PIECE(^(0),U,12)=78

           SET $PIECE(^(0),U,13)=0

           SET $PIECE(^(0),U,15)=9999999.64

 +6        SET ^ATXAX(APCLTX,21,0)="^9002226.02101A^0^0"

 +7        SET APCLTEXT="TBHF"

           FOR APCLX=1:1:4

               SET X=$PIECE($TEXT(@APCLTEXT+APCLX),";;",2)

               SET DIC="^AUTTHF("

               SET DIC(0)="M"

               DO ^DIC

               KILL DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0

               IF $PIECE(Y,U)>0

                   Begin DoDot:1

 +8                    SET ^ATXAX(APCLTX,21,APCLX,0)=+Y

                       SET $PIECE(^ATXAX(APCLTX,21,0),U,3)=APCLX

                       SET $PIECE(^(0),U,4)=APCLX

                       SET ^ATXAX(APCLTX,21,"AA",+Y,APCLX)=""

 +9                    QUIT

                   End DoDot:1

 +10       SET DA=APCLTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +11       QUIT

TBHF      ;

 +1       ;;TB - TX UNTREATED

 +2       ;;TB - TX INCOMPLETE

 +3       ;;TB - TX COMPLETE

 +4       ;;TB - TX UNKNOWN

TOB       ;

 +1       ;;NON-TOBACCO USER

 +2       ;;CURRENT SMOKER

 +3       ;;CURRENT SMOKELESS

 +4       ;;PREVIOUS SMOKER

 +5       ;;PREVIOUS SMOKELESS

EDUC      ;

 +1       ;;DM-COMPLICATIONS

 +2       ;;DM-DIET

 +3       ;;DM-DISEASE PROCESS

 +4       ;;DM-EXERCISE

 +5       ;;DM-FOLLOW UP

 +6       ;;DM-FOOT CARE

 +7       ;;DM-GENERAL INFORMATION

 +8       ;;DM-LIFESTYLE ADAPTATIONS

 +9       ;;DM-MEDICATIONS

 +10      ;;DM-NUTRITION

ADA       ;

 +1       ;;0110

 +2       ;;0120

 +3       ;;0150

 +4       ;;9321

 +5       ;;9320

APCLPOS5.m