BGP21POS.m

BGP21POS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 08 Dec 2010 3:10 PM ;

 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66

 ;

 ;

 ;SEND OUT BGP TAXONOMIES

 ; The following line prevents the "Disable Options..." and "Move

 ; Routines..." questions from being asked during the install.

 I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0

 I $E($$VERSION^XPDUTL("BGP"),1,3)<"12.0" D MES^XPDUTL($$CJ^XLFSTR("Version 12.0 of BGP is required.  Not installed.",80)) D SORRY(2) I 1

 ;I '$$INSTALLD("BGP*11.1*1") D SORRY(2)

 ;I '$$INSTALLD("BKM*2.1*2") D SORRY(2)

 Q

 ;

PRE ;EP

 D PRE^BGP2POS2

 Q

POST ;EP - called from kids build

 ;D ^BGP21

 ;D ^BGP22

 D ^BGP23

 D ^BGP24

 D ^BGP25

 D ^BGP26

 D ^BGP27

 D ^BGP28

 D ^BGP29

 D ^BGP20

 D ^BGP2Y

 D ^BGP2W

 D ^BGP2V

 D ^BGP2T

 D DRUGS^BGP2POS1

 D ADA

 D SETTAXF

 D SETTAX

 Q

INSTALLD(BGPSTAL) ;EP - Determine if patch BGPSTAL was installed, where

 ; BGPSTAL is the name of the INSTALL.  E.g "AG*6.0*11".

 ;

 NEW BGPY,DIC,X,Y

 S X=$P(BGPSTAL,"*",1)

 S DIC="^DIC(9.4,",DIC(0)="FM",D="C"

 D IX^DIC

 I Y<1 D IMES Q 0

 S DIC=DIC_+Y_",22,",X=$P(BGPSTAL,"*",2)

 D ^DIC

 I Y<1 D IMES Q 0

 S DIC=DIC_+Y_",""PAH"",",X=$P(BGPSTAL,"*",3)

 D ^DIC

 S BGPY=Y

 D IMES

 Q $S(BGPY<1:0,1:1)

IMES ;

 D MES^XPDUTL($$CJ^XLFSTR("Patch """_BGPSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" installed.",IOM))

 Q

SORRY(X) ;

 KILL DIFQ

 I X=3 S XPDQUIT=2 Q

 S XPDQUIT=X

 W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)

 Q

ADA ;

 S ATXFLG=1

 S BGPDA=0 S BGPDA=$O(^ATXAX("B","BGP DENTAL EXAM ADA CODES",BGPDA))

 I BGPDA S DIK="^ATXAX(",DA=BGPDA D ^DIK  ;get rid of existing one

 W !,"Creating/Updating DENTAL EXAM ADA Codes Taxonomy..."

 S X="BGP 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 DENTAL EXAM ADA CODES TAX" Q

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

 S BGPX=0

 F X="0120","0150","0145",9990 S DIC="^AUTTADA(",DIC(0)="M" D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0 I $P(Y,U)>0 D

 .S BGPX=BGPX+1

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

 .Q

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

 Q

SETTAXF ;

 S X=0 F  S X=$O(^ATXLAB(X)) Q:X'=+X  D

 .Q:$P(^ATXLAB(X,0),U,9)]""

 .S $P(^ATXLAB(X,0),U,9)=60

 .Q

 Q

SETTAX ;

 S BGPTFI="" F  S BGPTFI=$O(^ATXAX("B",BGPTFI)) Q:BGPTFI=""  D

 .S BGPTDA=$O(^ATXAX("B",BGPTFI,0))

 .Q:'BGPTDA  ;did not find taxonomy

 .Q:'$$NS(BGPTFI)

 .S $P(^ATXAX(BGPTDA,0),U,4)="n"

 .S F=$P(^ATXAX(BGPTDA,0),U,15)

 .I $$RO(F) S $P(^ATXAX(BGPTDA,0),U,22)=1  ;SET READ ONLY

 .I BGPTFI[" NDC" S $P(^ATXAX(BGPTDA,0),U,22)=1  ;SET READY ONLY FOR NDC TAXONOMIES

SETP .;set packages in multiple

 .K DIC,DA,DR

 .S BGPPI=$O(^DIC(9.4,"C","BGP",0))

 .Q:BGPPI=""  ;NO PACKAGE

 .Q:$D(^ATXAX(BGPTDA,41,"B",BGPPI))

 .S X="`"_BGPPI,DIC="^ATXAX("_BGPTDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002226,4101,0),U,2),DA(1)=BGPTDA

 .D ^DIC

 .I Y=-1 W !,"updating package multiple for ",BGPPP," entry ",$P(^ATXAX(BGPDA,0),U)," failed"

 .K DIC,DA,Y,X

 .Q

 Q

RO(T) ;

 I T=81 Q 1

 I T=80 Q 1

 I T=80.1 Q 1

 I T=9999999.31 Q 1

 I T=9999999.64 Q 1

 I T=95.3 Q 1

 Q 0

NS(T,L) ;

 I $E(T,1,3)="BGP" Q 1

 I $E(T,1,7)="SURVEIL" Q 1

 Q 0

BGP21POS  ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 08 Dec 2010 3:10 PM ;

 +1       ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66

 +2       ;

 +3       ;

 +4       ;SEND OUT BGP TAXONOMIES

 +5       ; The following line prevents the "Disable Options..." and "Move

 +6       ; Routines..." questions from being asked during the install.

 +7        IF $GET(XPDENV)=1

               SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 +8        FOR X="XPO1","XPZ1","XPZ2","XPI1"

               SET XPDDIQ(X)=0

 +9        IF $EXTRACT($$VERSION^XPDUTL("BGP"),1,3)<"12.0"

               DO MES^XPDUTL($$CJ^XLFSTR("Version 12.0 of BGP is required.  Not installed.",80))

               DO SORRY(2)

               IF 1

 +10      ;I '$$INSTALLD("BGP*11.1*1") D SORRY(2)

 +11      ;I '$$INSTALLD("BKM*2.1*2") D SORRY(2)

 +12       QUIT 

 +13      ;

PRE       ;EP

 +1        DO PRE^BGP2POS2

 +2        QUIT 

POST      ;EP - called from kids build

 +1       ;D ^BGP21

 +2       ;D ^BGP22

 +3        DO ^BGP23

 +4        DO ^BGP24

 +5        DO ^BGP25

 +6        DO ^BGP26

 +7        DO ^BGP27

 +8        DO ^BGP28

 +9        DO ^BGP29

 +10       DO ^BGP20

 +11       DO ^BGP2Y

 +12       DO ^BGP2W

 +13       DO ^BGP2V

 +14       DO ^BGP2T

 +15       DO DRUGS^BGP2POS1

 +16       DO ADA

 +17       DO SETTAXF

 +18       DO SETTAX

 +19       QUIT 

INSTALLD(BGPSTAL) ;EP - Determine if patch BGPSTAL was installed, where

 +1       ; BGPSTAL is the name of the INSTALL.  E.g "AG*6.0*11".

 +2       ;

 +3        NEW BGPY,DIC,X,Y

 +4        SET X=$PIECE(BGPSTAL,"*",1)

 +5        SET DIC="^DIC(9.4,"

           SET DIC(0)="FM"

           SET D="C"

 +6        DO IX^DIC

 +7        IF Y<1

               DO IMES

               QUIT 0

 +8        SET DIC=DIC_+Y_",22,"

           SET X=$PIECE(BGPSTAL,"*",2)

 +9        DO ^DIC

 +10       IF Y<1

               DO IMES

               QUIT 0

 +11       SET DIC=DIC_+Y_",""PAH"","

           SET X=$PIECE(BGPSTAL,"*",3)

 +12       DO ^DIC

 +13       SET BGPY=Y

 +14       DO IMES

 +15       QUIT $SELECT(BGPY<1:0,1:1)

IMES      ;

 +1        DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BGPSTAL_""" is"_$SELECT(Y<1:" *NOT*",1:"")_" installed.",IOM))

 +2        QUIT 

SORRY(X)  ;

 +1        KILL DIFQ

 +2        IF X=3

               SET XPDQUIT=2

               QUIT 

 +3        SET XPDQUIT=X

 +4        WRITE *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)

 +5        QUIT 

ADA       ;

 +1        SET ATXFLG=1

 +2        SET BGPDA=0

           SET BGPDA=$ORDER(^ATXAX("B","BGP DENTAL EXAM ADA CODES",BGPDA))

 +3       ;get rid of existing one

           IF BGPDA

               SET DIK="^ATXAX("

               SET DA=BGPDA

               DO ^DIK

 +4        WRITE !,"Creating/Updating DENTAL EXAM ADA Codes Taxonomy..."

 +5        SET X="BGP 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

 +6        IF Y=-1

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

               QUIT 

 +7        SET BGPTX=+Y

           SET $PIECE(^ATXAX(BGPTX,0),U,2)="BGP 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(BGPTX,21,0)="^9002226.02101A^0^0"

 +8        SET BGPX=0

 +9        FOR X="0120","0150","0145",9990

               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

 +10                   SET BGPX=BGPX+1

 +11                   SET ^ATXAX(BGPTX,21,BGPX,0)=+Y

                       SET $PIECE(^ATXAX(BGPTX,21,0),U,3)=BGPX

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

                       SET ^ATXAX(BGPTX,21,"AA",+Y,BGPX)=""

 +12                   QUIT 

                   End DoDot:1

 +13       SET DA=BGPTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +14       QUIT 

SETTAXF   ;

 +1        SET X=0

           FOR 

               SET X=$ORDER(^ATXLAB(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +2                IF $PIECE(^ATXLAB(X,0),U,9)]""

                       QUIT 

 +3                SET $PIECE(^ATXLAB(X,0),U,9)=60

 +4                QUIT 

               End DoDot:1

 +5        QUIT 

SETTAX    ;

 +1        SET BGPTFI=""

           FOR 

               SET BGPTFI=$ORDER(^ATXAX("B",BGPTFI))

               IF BGPTFI=""

                   QUIT 

               Begin DoDot:1

 +2                SET BGPTDA=$ORDER(^ATXAX("B",BGPTFI,0))

 +3       ;did not find taxonomy

                   IF 'BGPTDA

                       QUIT 

 +4                IF '$$NS(BGPTFI)

                       QUIT 

 +5                SET $PIECE(^ATXAX(BGPTDA,0),U,4)="n"

 +6                SET F=$PIECE(^ATXAX(BGPTDA,0),U,15)

 +7       ;SET READ ONLY

                   IF $$RO(F)

                       SET $PIECE(^ATXAX(BGPTDA,0),U,22)=1

 +8       ;SET READY ONLY FOR NDC TAXONOMIES

                   IF BGPTFI[" NDC"

                       SET $PIECE(^ATXAX(BGPTDA,0),U,22)=1

SETP      ;set packages in multiple

 +1                KILL DIC,DA,DR

 +2                SET BGPPI=$ORDER(^DIC(9.4,"C","BGP",0))

 +3       ;NO PACKAGE

                   IF BGPPI=""

                       QUIT 

 +4                IF $DATA(^ATXAX(BGPTDA,41,"B",BGPPI))

                       QUIT 

 +5                SET X="`"_BGPPI

                   SET DIC="^ATXAX("_BGPTDA_",41,"

                   SET DIC(0)="L"

                   SET DIC("P")=$PIECE(^DD(9002226,4101,0),U,2)

                   SET DA(1)=BGPTDA

 +6                DO ^DIC

 +7                IF Y=-1

                       WRITE !,"updating package multiple for ",BGPPP," entry ",$PIECE(^ATXAX(BGPDA,0),U)," failed"

 +8                KILL DIC,DA,Y,X

 +9                QUIT 

               End DoDot:1

 +10       QUIT 

RO(T)     ;

 +1        IF T=81

               QUIT 1

 +2        IF T=80

               QUIT 1

 +3        IF T=80.1

               QUIT 1

 +4        IF T=9999999.31

               QUIT 1

 +5        IF T=9999999.64

               QUIT 1

 +6        IF T=95.3

               QUIT 1

 +7        QUIT 0

NS(T,L)   ;

 +1        IF $EXTRACT(T,1,3)="BGP"

               QUIT 1

 +2        IF $EXTRACT(T,1,7)="SURVEIL"

               QUIT 1

 +3        QUIT 0