BDMDGPS.m

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

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51

 ;

 ;

MAIN ;EP

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

 ;D ^BDM8X

 Q

 ;

DRUG ;EP set up drug taxonomies

 S ATXFLG=1

 S BDMX="DM AUDIT INCRETIN MIMETIC",BDMTAX="",BDMNDCT="" D DRUG1

 S BDMX="DM AUDIT DPP4 INHIBITOR DRUGS",BDMTAX="",BDMNDCT="" D DRUG1

 Q

DRUG1 ;

 S BDMTX=$O(^ATXAX("B",BDMX,0))

 I 'BDMTX D  Q:Y=-1

 .W !,"Creating ",BDMX," Taxonomy..."

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

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

 .S BDMTX=+Y,$P(^ATXAX(BDMTX,0),U,2)=BDMX,$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(BDMTX,21,0)="^9002226.02101A^0^0"

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

 I $G(BDMTAX)]"" D

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

 .S BDMC=B

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

 .S Z=$O(^ATXAX("B",BDMTAX,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(BDMTX,21,"B",J))

 ..S BDMC=BDMC+1,^ATXAX(BDMTX,21,BDMC,0)=J_U_J

 I $G(BDMNDCT)]"" D

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

 .S BDMC=B

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

 .S Z=$O(^ATXAX("B",BDMNDCT,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(BDMTX,21,"B",J))

 ..S BDMC=BDMC+1,^ATXAX(BDMTX,21,BDMC,0)=J_U_J

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

 Q

 ;

LAB ;EP

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

 Q

LAB1 ;

 S BDMDG=$O(^ATXLAB("B",BDMX,0))

 Q:BDMDG  ;taxonomy already exists

 W !,"Creating ",BDMX," Taxonomy..."

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

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

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

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

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

 Q

 ;

LOINC ;EP

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

 D LOINC1

 Q

 ;

LOINC1 ;

 S BDMDG=$O(^ATXAX("B",BDMX,0))

 Q:BDMDG  ;taxonomy already exisits

 W !,"Creating ",BDMX," Taxonomy..."

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

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

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

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

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

 Q

 ;

MENU ;EP - add items to menu

 F BDMX="BDM DM2019 AUDIT MENU" D

 .S BDMY="DM08"

 .S X=$$ADD^XPDMENU("BDM M MAIN DM MENU",BDMX,BDMY,9)

 Q

 ;

DELFL ;delete entries out of the file before reinstalling

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

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

 Q

 ;

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

 +1       ;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51

 +2       ;

 +3       ;

MAIN      ;EP

 +1       ;LAB,LOINC,MENU

           DO DRUG

           DO LAB

           DO MENU

 +2       ;D ^BDM8X

 +3        QUIT 

 +4       ;

DRUG      ;EP set up drug taxonomies

 +1        SET ATXFLG=1

 +2        SET BDMX="DM AUDIT INCRETIN MIMETIC"

           SET BDMTAX=""

           SET BDMNDCT=""

           DO DRUG1

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

           SET BDMTAX=""

           SET BDMNDCT=""

           DO DRUG1

 +4        QUIT 

DRUG1     ;

 +1        SET BDMTX=$ORDER(^ATXAX("B",BDMX,0))

 +2        IF 'BDMTX

               Begin DoDot:1

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

 +4                SET X=BDMX

                   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 ",BDMX," TAX"

                       QUIT 

 +6                SET BDMTX=+Y

                   SET $PIECE(^ATXAX(BDMTX,0),U,2)=BDMX

                   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(BDMTX,21,0)="^9002226.02101A^0^0"

               End DoDot:1

               IF Y=-1

                   QUIT 

 +7        SET DA=BDMTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +8        IF $GET(BDMTAX)]""

               Begin DoDot:1

 +9                SET A=0

                   SET B=""

                   FOR 

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

                       IF A'=+A

                           QUIT 

                       SET B=A

 +10               SET BDMC=B

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

 +12               SET Z=$ORDER(^ATXAX("B",BDMTAX,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(BDMTX,21,"B",J))

                                       QUIT 

 +15                               SET BDMC=BDMC+1

                                   SET ^ATXAX(BDMTX,21,BDMC,0)=J_U_J

                               End DoDot:2

               End DoDot:1

 +16       IF $GET(BDMNDCT)]""

               Begin DoDot:1

 +17               SET A=0

                   SET B=""

                   FOR 

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

                       IF A'=+A

                           QUIT 

                       SET B=A

 +18               SET BDMC=B

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

 +20               SET Z=$ORDER(^ATXAX("B",BDMNDCT,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(BDMTX,21,"B",J))

                                       QUIT 

 +23                               SET BDMC=BDMC+1

                                   SET ^ATXAX(BDMTX,21,BDMC,0)=J_U_J

                               End DoDot:2

               End DoDot:1

 +24       SET DA=BDMTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +25       QUIT 

 +26      ;

LAB       ;EP

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

           DO LAB1

 +2        QUIT 

LAB1      ;

 +1        SET BDMDG=$ORDER(^ATXLAB("B",BDMX,0))

 +2       ;taxonomy already exists

           IF BDMDG

               QUIT 

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

 +4        SET X=BDMX

           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 ",BDMX," TAX"

               QUIT 

 +6        SET BDMTX=+Y

           SET $PIECE(^ATXLAB(BDMTX,0),U,2)=BDMX

           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(BDMTX,21,0)="^9002228.02101PA^0^0"

 +8        SET DA=BDMTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +9        QUIT 

 +10      ;

LOINC     ;EP

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

 +2        DO LOINC1

 +3        QUIT 

 +4       ;

LOINC1    ;

 +1        SET BDMDG=$ORDER(^ATXAX("B",BDMX,0))

 +2       ;taxonomy already exisits

           IF BDMDG

               QUIT 

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

 +4        SET X=BDMX

           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 ",BDMX," TAX"

               QUIT 

 +6        SET BDMTX=+Y

           SET $PIECE(^ATXAX(BDMTX,0),U,2)=BDMX

           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(BDMTX,21,0)="^9002228.02101PA^0^0"

 +8        SET DA=BDMTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +9        QUIT 

 +10      ;

MENU      ;EP - add items to menu

 +1        FOR BDMX="BDM DM2019 AUDIT MENU"

               Begin DoDot:1

 +2                SET BDMY="DM08"

 +3                SET X=$$ADD^XPDMENU("BDM M MAIN DM MENU",BDMX,BDMY,9)

               End DoDot:1

 +4        QUIT 

 +5       ;

DELFL     ;delete entries out of the file before reinstalling

 +1        FOR DA=1:1:40

               SET DIK="^BDMRECD("

               DO ^DIK

 +2        FOR DA=1:1:20

               SET DIK="^BDMDMTX("

               DO ^DIK

 +3        QUIT 

 +4       ;