APCLD8PS.m

APCLD8PS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM ;

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

 ;

 ;

MAIN ;EP

 D DRUG,LAB,MENU  ;LAB,LOINC,MENU

 D ^APCL8X

 Q

 ;

DRUG ;EP set up drug taxonomies

 S ATXFLG=1

 S APCLX="DM AUDIT INCRETIN MIMETIC",APCLTAX="",APCLNDCT="" D DRUG1

 S APCLX="DM AUDIT DPP4 INHIBITOR DRUGS",APCLTAX="",APCLNDCT="" D DRUG1

 Q

DRUG1 ;

 S APCLTX=$O(^ATXAX("B",APCLX,0))

 I 'APCLTX D  Q:Y=-1

 .W !,"Creating ",APCLX," Taxonomy..."

 .S X=APCLX,DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I

 .I Y=-1 W !!,"ERROR IN CREATING ",APCLX," TAX" Q

 .S APCLTX=+Y,$P(^ATXAX(APCLTX,0),U,2)=APCLX,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=173,$P(^(0),U,13)=0,$P(^(0),U,15)=50,^ATXAX(APCLTX,21,0)="^9002226.02101A^0^0"

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

 I $G(APCLTAX)]"" D

 .S A=0,B="" F  S A=$O(^ATXAX(APCLTX,21,A)) Q:A'=+A  S B=A

 .S APCLC=B

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

 .S Z=$O(^ATXAX("B",APCLTAX,0))

 .S J=0 F  S J=$O(^PSDRUG(J)) Q:J'=+J  S C=$P($G(^PSDRUG(J,0)),U,2) I C]"",$D(^ATXAX(Z,21,"B",C)) D

 ..Q:$D(^ATXAX(APCLTX,21,"B",J))

 ..S APCLC=APCLC+1,^ATXAX(APCLTX,21,APCLC,0)=J_U_J

 I $G(APCLNDCT)]"" D

 .S A=0,B="" F  S A=$O(^ATXAX(APCLTX,21,A)) Q:A'=+A  S B=A

 .S APCLC=B

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

 .S Z=$O(^ATXAX("B",APCLNDCT,0))

 .S J=0 F  S J=$O(^PSDRUG(J)) Q:J'=+J  S C=$P($G(^PSDRUG(J,2)),U,4) I C]"",$D(^ATXAX(Z,21,"B",C)) D

 ..Q:$D(^ATXAX(APCLTX,21,"B",J))

 ..S APCLC=APCLC+1,^ATXAX(APCLTX,21,APCLC,0)=J_U_J

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

 Q

 ;

LAB ;EP

 S APCLX="DM AUDIT P/C RATIO TAX" D LAB1

 Q

LAB1 ;

 S APCLDA=$O(^ATXLAB("B",APCLX,0))

 Q:APCLDA  ;taxonomy already exists

 W !,"Creating ",APCLX," Taxonomy..."

 S X=APCLX,DIC="^ATXLAB(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I

 I Y=-1 W !!,"ERROR IN CREATING ",APCLX," TAX" Q

 S APCLTX=+Y,$P(^ATXLAB(APCLTX,0),U,2)=APCLX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="B",$P(^(0),U,9)=60

 S ^ATXLAB(APCLTX,21,0)="^9002228.02101PA^0^0"

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

 Q

 ;

LOINC ;EP

 S APCLX="DM AUDIT P/C RATIO LOINC"

 D LOINC1

 Q

 ;

LOINC1 ;

 S APCLDA=$O(^ATXAX("B",APCLX,0))

 Q:APCLDA  ;taxonomy already exisits

 W !,"Creating ",APCLX," Taxonomy..."

 S X=APCLX,DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I

 I Y=-1 W !!,"ERROR IN CREATING ",APCLX," TAX" Q

 S APCLTX=+Y,$P(^ATXAX(APCLTX,0),U,2)=APCLX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="FIHS",$P(^(0),U,9)=95.3

 S ^ATXAX(APCLTX,21,0)="^9002228.02101PA^0^0"

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

 Q

 ;

MENU ;EP - add items to menu

 F APCLX="APCL DM2008 AUDIT MENU" D

 .S APCLY="DM08"

 .S X=$$ADD^XPDMENU("APCL M MAIN DM MENU",APCLX,APCLY,9)

 Q

 ;

DELFL ;delete entries out of the file before reinstalling

 F DA=1:1:40 S DIK="^APCLRECD(" D ^DIK

 F DA=1:1:20 S DIK="^APCLDMTX(" D ^DIK

 Q

 ;

APCLD8PS  ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM ;

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

 +2       ;

 +3       ;

MAIN      ;EP

 +1       ;LAB,LOINC,MENU

           DO DRUG

           DO LAB

           DO MENU

 +2        DO ^APCL8X

 +3        QUIT 

 +4       ;

DRUG      ;EP set up drug taxonomies

 +1        SET ATXFLG=1

 +2        SET APCLX="DM AUDIT INCRETIN MIMETIC"

           SET APCLTAX=""

           SET APCLNDCT=""

           DO DRUG1

 +3        SET APCLX="DM AUDIT DPP4 INHIBITOR DRUGS"

           SET APCLTAX=""

           SET APCLNDCT=""

           DO DRUG1

 +4        QUIT 

DRUG1     ;

 +1        SET APCLTX=$ORDER(^ATXAX("B",APCLX,0))

 +2        IF 'APCLTX

               Begin DoDot:1

 +3                WRITE !,"Creating ",APCLX," Taxonomy..."

 +4                SET X=APCLX

                   SET DIC="^ATXAX("

                   SET DIC(0)="L"

                   SET DIADD=1

                   SET DLAYGO=9002226

                   DO ^DIC

                   KILL DIC,DA,DIADD,DLAYGO,I

 +5                IF Y=-1

                       WRITE !!,"ERROR IN CREATING ",APCLX," TAX"

                       QUIT 

 +6                SET APCLTX=+Y

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

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

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

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

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

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

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

               End DoDot:1

               IF Y=-1

                   QUIT 

 +7        SET DA=APCLTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +8        IF $GET(APCLTAX)]""

               Begin DoDot:1

 +9                SET A=0

                   SET B=""

                   FOR 

                       SET A=$ORDER(^ATXAX(APCLTX,21,A))

                       IF A'=+A

                           QUIT 

                       SET B=A

 +10               SET APCLC=B

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

 +12               SET Z=$ORDER(^ATXAX("B",APCLTAX,0))

 +13               SET J=0

                   FOR 

                       SET J=$ORDER(^PSDRUG(J))

                       IF J'=+J

                           QUIT 

                       SET C=$PIECE($GET(^PSDRUG(J,0)),U,2)

                       IF C]""

                           IF $DATA(^ATXAX(Z,21,"B",C))

                               Begin DoDot:2

 +14                               IF $DATA(^ATXAX(APCLTX,21,"B",J))

                                       QUIT 

 +15                               SET APCLC=APCLC+1

                                   SET ^ATXAX(APCLTX,21,APCLC,0)=J_U_J

                               End DoDot:2

               End DoDot:1

 +16       IF $GET(APCLNDCT)]""

               Begin DoDot:1

 +17               SET A=0

                   SET B=""

                   FOR 

                       SET A=$ORDER(^ATXAX(APCLTX,21,A))

                       IF A'=+A

                           QUIT 

                       SET B=A

 +18               SET APCLC=B

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

 +20               SET Z=$ORDER(^ATXAX("B",APCLNDCT,0))

 +21               SET J=0

                   FOR 

                       SET J=$ORDER(^PSDRUG(J))

                       IF J'=+J

                           QUIT 

                       SET C=$PIECE($GET(^PSDRUG(J,2)),U,4)

                       IF C]""

                           IF $DATA(^ATXAX(Z,21,"B",C))

                               Begin DoDot:2

 +22                               IF $DATA(^ATXAX(APCLTX,21,"B",J))

                                       QUIT 

 +23                               SET APCLC=APCLC+1

                                   SET ^ATXAX(APCLTX,21,APCLC,0)=J_U_J

                               End DoDot:2

               End DoDot:1

 +24       SET DA=APCLTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +25       QUIT 

 +26      ;

LAB       ;EP

 +1        SET APCLX="DM AUDIT P/C RATIO TAX"

           DO LAB1

 +2        QUIT 

LAB1      ;

 +1        SET APCLDA=$ORDER(^ATXLAB("B",APCLX,0))

 +2       ;taxonomy already exists

           IF APCLDA

               QUIT 

 +3        WRITE !,"Creating ",APCLX," Taxonomy..."

 +4        SET X=APCLX

           SET DIC="^ATXLAB("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9002228

           DO ^DIC

           KILL DIC,DA,DIADD,DLAYGO,I

 +5        IF Y=-1

               WRITE !!,"ERROR IN CREATING ",APCLX," TAX"

               QUIT 

 +6        SET APCLTX=+Y

           SET $PIECE(^ATXLAB(APCLTX,0),U,2)=APCLX

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

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

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

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

 +7        SET ^ATXLAB(APCLTX,21,0)="^9002228.02101PA^0^0"

 +8        SET DA=APCLTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +9        QUIT 

 +10      ;

LOINC     ;EP

 +1        SET APCLX="DM AUDIT P/C RATIO LOINC"

 +2        DO LOINC1

 +3        QUIT 

 +4       ;

LOINC1    ;

 +1        SET APCLDA=$ORDER(^ATXAX("B",APCLX,0))

 +2       ;taxonomy already exisits

           IF APCLDA

               QUIT 

 +3        WRITE !,"Creating ",APCLX," Taxonomy..."

 +4        SET X=APCLX

           SET DIC="^ATXAX("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9002228

           DO ^DIC

           KILL DIC,DA,DIADD,DLAYGO,I

 +5        IF Y=-1

               WRITE !!,"ERROR IN CREATING ",APCLX," TAX"

               QUIT 

 +6        SET APCLTX=+Y

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

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

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

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

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

 +7        SET ^ATXAX(APCLTX,21,0)="^9002228.02101PA^0^0"

 +8        SET DA=APCLTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +9        QUIT 

 +10      ;

MENU      ;EP - add items to menu

 +1        FOR APCLX="APCL DM2008 AUDIT MENU"

               Begin DoDot:1

 +2                SET APCLY="DM08"

 +3                SET X=$$ADD^XPDMENU("APCL M MAIN DM MENU",APCLX,APCLY,9)

               End DoDot:1

 +4        QUIT 

 +5       ;

DELFL     ;delete entries out of the file before reinstalling

 +1        FOR DA=1:1:40

               SET DIK="^APCLRECD("

               DO ^DIK

 +2        FOR DA=1:1:20

               SET DIK="^APCLDMTX("

               DO ^DIK

 +3        QUIT 

 +4       ;