Routine: ATXPOS2

ATXPOS2 ; TUCSON-OHPRD/LAB - IHS-TUCSON/GIS/THL ;  [ 10/12/94  1:37 PM ]

 ;;5.0;TAXONOMY SYSTEM;;OCT 12, 1994

OBESSUR ;EP -surveillance obesity

 W !!,"Checking OBESITY Surveillance Taxonomy..."

 S ATXFLG="",X="SURVEILLANCE OBESITY",DIC="^ATXAX(",DIC(0)="MO" D ^DIC K DIC,DA,DR,DIADD,DLAYGO,D0

 S ATXTAX=+Y I ATXTAX>0 S DA=ATXTAX,DIK="^ATXAX(" D ^DIK K DIK,DA,DR

 S:ATXTAX>0 DINUM=ATXTAX S ATXFLG="",X="SURVEILLANCE OBESITY",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DR,DIADD,DLAYGO,D0

 S ATXTAX=+Y

 S $P(^ATXAX(ATXTAX,0),U,2)="OBES SURV - USED BY HLTH SUMM",$P(^(0),U,4)="n",$P(^(0),U,5)=DUZ,$P(^(0),U,6)=2600101,$P(^(0),U,8)=1,$P(^(0),U,9)=DT,$P(^(0),U,12)=31,$P(^(0),U,13)=1,$P(^(0),U,14)="BA"

 S $P(^ATXAX(ATXTAX,0),U,15)=80,$P(^(0),U,16)=1

 S ^ATXAX(ATXTAX,11,0)="^^1^1^2940510^^^^",^ATXAX(ATXTAX,11,1,0)="ICD codes:  278.0"

 S ^ATXAX(ATXTAX,21,0)="^9002226.02102^1^1",^ATXAX(ATXTAX,21,1,0)="278.0^278.0"

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

 S ATXX=ATXTAX D ZTM^ATXAX

 I $O(^ATXPAT(ATXTAX,11,0)) W !,"Pts already entered for this taxonomy.",! Q

 S ATXX=ATXTAX

 I '$D(^ATXPAT(ATXX,0)) S DIADD="",DIC="^ATXPAT(",DIC(0)="L",X="`"_ATXX,DIC("DR")=".02////"_DT_";.03////"_DUZ D ^DIC K DIADD,DIC,DR S ^ATXPAT(ATXX,11,0)="^9002227.01101PA^0^0"

 D TSKMN^ATXENP

TBSUR ;EP - surveillance tb

 W !!,"Checking TB Surveillance Taxonomy..."

 S ATXFLG="",X="SURVEILLANCE TUBERCULOSIS",DIC="^ATXAX(",DIC(0)="MO" D ^DIC K DIC,DA,DINUM,DR,DIADD,DLAYGO,D0,DD,DD

 S ATXTAX=+Y I ATXTAX>0 S DA=ATXTAX,DIK="^ATXAX(" D ^DIK K DIK,DA,DR ;delete current one if it exists

 S:ATXTAX>0 DINUM=ATXTAX S ATXFLG="",X="SURVEILLANCE TUBERCULOSIS",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DINUM,DR,DIADD,DLAYGO,D0,DD

 S ATXTAX=+Y

 S $P(^ATXAX(ATXTAX,0),U,2)="TB SURV - USED BY HLTH SUMM",$P(^(0),U,4)="n",$P(^(0),U,5)=DUZ,$P(^(0),U,6)=2600101,$P(^(0),U,8)=1,$P(^(0),U,9)=DT,$P(^(0),U,12)=31,$P(^(0),U,13)=1,$P(^(0),U,14)="BA"

 S $P(^ATXAX(ATXTAX,0),U,15)=80,$P(^(0),U,16)=1

 S ^ATXAX(ATXTAX,11,0)="^^1^1^2940510^^^^",^ATXAX(ATXTAX,11,1,0)="ICD codes:  010.0-018.96, late effects 137.0-137.4; Positive PPD, Tine or Monovac - 795.5"

 S ^ATXAX(ATXTAX,21,0)="^9002226.02102^3^3",^ATXAX(ATXTAX,21,1,0)="010.00^018.96",^ATXAX(ATXTAX,21,2,0)="137.0^137.4",^ATXAX(ATXTAX,21,3,0)="795.5^795.5"

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

 S ATXX=ATXTAX D ZTM^ATXAX ;update all these codes in icd9 file

 I $O(^ATXPAT(ATXTAX,11,0)) W !,"Pts already entered for this taxonomy.",! Q

 S ATXX=ATXTAX

 I '$D(^ATXPAT(ATXX,0)) S DIADD="",DIC="^ATXPAT(",DIC(0)="L",X="`"_ATXX,DIC("DR")=".02////"_DT_";.03////"_DUZ D ^DIC K DIADD,DIC,DR S ^ATXPAT(ATXX,11,0)="^9002227.01101PA^0^0"

 D TSKMN^ATXENP ;enter patients into patient taxonomy

PNEUSUR ;EP -pneumococcal risk

 D PNEUSUR^ATXPOS3

ATXPOS2   ; TUCSON-OHPRD/LAB - IHS-TUCSON/GIS/THL ;  [ 10/12/94  1:37 PM ]

 +1       ;;5.0;TAXONOMY SYSTEM;;OCT 12, 1994

OBESSUR   ;EP -surveillance obesity

 +1        WRITE !!,"Checking OBESITY Surveillance Taxonomy..."

 +2        SET ATXFLG=""

           SET X="SURVEILLANCE OBESITY"

           SET DIC="^ATXAX("

           SET DIC(0)="MO"

           DO ^DIC

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

 +3        SET ATXTAX=+Y

           IF ATXTAX>0

               SET DA=ATXTAX

               SET DIK="^ATXAX("

               DO ^DIK

               KILL DIK,DA,DR

 +4        IF ATXTAX>0

               SET DINUM=ATXTAX

           SET ATXFLG=""

           SET X="SURVEILLANCE OBESITY"

           SET DIC="^ATXAX("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9002226

           DO ^DIC

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

 +5        SET ATXTAX=+Y

 +6        SET $PIECE(^ATXAX(ATXTAX,0),U,2)="OBES SURV - USED BY HLTH SUMM"

           SET $PIECE(^(0),U,4)="n"

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

           SET $PIECE(^(0),U,6)=2600101

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

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

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

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

           SET $PIECE(^(0),U,14)="BA"

 +7        SET $PIECE(^ATXAX(ATXTAX,0),U,15)=80

           SET $PIECE(^(0),U,16)=1

 +8        SET ^ATXAX(ATXTAX,11,0)="^^1^1^2940510^^^^"

           SET ^ATXAX(ATXTAX,11,1,0)="ICD codes:  278.0"

 +9        SET ^ATXAX(ATXTAX,21,0)="^9002226.02102^1^1"

           SET ^ATXAX(ATXTAX,21,1,0)="278.0^278.0"

 +10       SET DA=ATXTAX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +11       SET ATXX=ATXTAX

           DO ZTM^ATXAX

 +12       IF $ORDER(^ATXPAT(ATXTAX,11,0))

               WRITE !,"Pts already entered for this taxonomy.",!

               QUIT

 +13       SET ATXX=ATXTAX

 +14       IF '$DATA(^ATXPAT(ATXX,0))

               SET DIADD=""

               SET DIC="^ATXPAT("

               SET DIC(0)="L"

               SET X="`"_ATXX

               SET DIC("DR")=".02////"_DT_";.03////"_DUZ

               DO ^DIC

               KILL DIADD,DIC,DR

               SET ^ATXPAT(ATXX,11,0)="^9002227.01101PA^0^0"

 +15       DO TSKMN^ATXENP

 +16       QUIT

TBSUR     ;EP - surveillance tb

 +1        WRITE !!,"Checking TB Surveillance Taxonomy..."

 +2        SET ATXFLG=""

           SET X="SURVEILLANCE TUBERCULOSIS"

           SET DIC="^ATXAX("

           SET DIC(0)="MO"

           DO ^DIC

           KILL DIC,DA,DINUM,DR,DIADD,DLAYGO,D0,DD,DD

 +3       ;delete current one if it exists

           SET ATXTAX=+Y

           IF ATXTAX>0

               SET DA=ATXTAX

               SET DIK="^ATXAX("

               DO ^DIK

               KILL DIK,DA,DR

 +4        IF ATXTAX>0

               SET DINUM=ATXTAX

           SET ATXFLG=""

           SET X="SURVEILLANCE TUBERCULOSIS"

           SET DIC="^ATXAX("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9002226

           DO ^DIC

           KILL DIC,DA,DINUM,DR,DIADD,DLAYGO,D0,DD

 +5        SET ATXTAX=+Y

 +6        SET $PIECE(^ATXAX(ATXTAX,0),U,2)="TB SURV - USED BY HLTH SUMM"

           SET $PIECE(^(0),U,4)="n"

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

           SET $PIECE(^(0),U,6)=2600101

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

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

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

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

           SET $PIECE(^(0),U,14)="BA"

 +7        SET $PIECE(^ATXAX(ATXTAX,0),U,15)=80

           SET $PIECE(^(0),U,16)=1

 +8        SET ^ATXAX(ATXTAX,11,0)="^^1^1^2940510^^^^"

           SET ^ATXAX(ATXTAX,11,1,0)="ICD codes:  010.0-018.96, late effects 137.0-137.4; Positive PPD, Tine or Monovac - 795.5"

 +9        SET ^ATXAX(ATXTAX,21,0)="^9002226.02102^3^3"

           SET ^ATXAX(ATXTAX,21,1,0)="010.00^018.96"

           SET ^ATXAX(ATXTAX,21,2,0)="137.0^137.4"

           SET ^ATXAX(ATXTAX,21,3,0)="795.5^795.5"

 +10       SET DA=ATXTAX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +11      ;update all these codes in icd9 file

           SET ATXX=ATXTAX

           DO ZTM^ATXAX

 +12       IF $ORDER(^ATXPAT(ATXTAX,11,0))

               WRITE !,"Pts already entered for this taxonomy.",!

               QUIT

 +13       SET ATXX=ATXTAX

 +14       IF '$DATA(^ATXPAT(ATXX,0))

               SET DIADD=""

               SET DIC="^ATXPAT("

               SET DIC(0)="L"

               SET X="`"_ATXX

               SET DIC("DR")=".02////"_DT_";.03////"_DUZ

               DO ^DIC

               KILL DIADD,DIC,DR

               SET ^ATXPAT(ATXX,11,0)="^9002227.01101PA^0^0"

 +15      ;enter patients into patient taxonomy

           DO TSKMN^ATXENP

 +16       QUIT

PNEUSUR   ;EP -pneumococcal risk

 +1        DO PNEUSUR^ATXPOS3

 +2        QUIT

ATXPOS2.m