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
Q
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
Q
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
Q
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
Q
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
Q
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
