BGP9POS.m

BGP9POS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM 25 Nov 2007 7:41 PM ; 

 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009

 ;

 ;

 ;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 '$$INSTALLD("BGP*8.0*3") D SORRY(2)

 Q

 ;

PRE ;EP

 D PRE^BGP9POS2

 Q

POST ;EP - called from kids build

 ;fix 05, 06, 07, 08 mastectomy procedures taxonomies

 S DA=$O(^BGPTAXV("B","BGP MASTECTOMY PROCEDURES",0))

 I DA S DIE="^BGPTAXV(",DR=".01///"_"BGP BILAT MASTECT PROCEDURES" D ^DIE K DA,DIE,DR

 S DA=$O(^BGPTAXS("B","BGP MASTECTOMY PROCEDURES",0))

 I DA S DIE="^BGPTAXS(",DR=".01///"_"BGP BILAT MASTECT PROCEDURES" D ^DIE K DA,DIE,DR

 S DA=$O(^BGPTAXA("B","BGP MASTECTOMY PROCEDURES",0))

 I DA S DIE="^BGPTAXA(",DR=".01///"_"BGP BILAT MASTECT PROCEDURES" D ^DIE K DA,DIE,DR

 S DA=$O(^BGPTAXE("B","BGP MASTECTOMY PROCEDURES",0))

 I DA S DIE="^BGPTAXE(",DR=".01///"_"BGP BILAT MASTECT PROCEDURES" D ^DIE K DA,DIE,DR

 S DA=$O(^BGPTAXV("B","BGP TOTAL CHOLECTOMY PROCS",0))

 I DA S DIE="^BGPTAXV(",DR=".01///"_"BGP TOTAL COLECTOMY PROCS" D ^DIE K DA,DIE,DR

 S DA=$O(^BGPTAXS("B","BGP TOTAL CHOLECTOMY PROCS",0))

 I DA S DIE="^BGPTAXS(",DR=".01///"_"BGP TOTAL COLECTOMY PROCS" D ^DIE K DA,DIE,DR

 S DA=$O(^BGPTAXA("B","BGP TOTAL CHOLECTOMY PROCS",0))

 I DA S DIE="^BGPTAXA(",DR=".01///"_"BGP TOTAL COLECTOMY PROCS" D ^DIE K DA,DIE,DR

 S DA=$O(^BGPTAXE("B","BGP TOTAL CHOLECTOMY PROCS",0))

 I DA S DIE="^BGPTAXE(",DR=".01///"_"BGP TOTAL COLECTOMY PROCS" D ^DIE K DA,DIE,DR

 S DA=$O(^BGPTAXV("B","BGP TOTAL CHOLECTOMY CPTS",0))

 I DA S DIE="^BGPTAXV(",DR=".01///"_"BGP TOTAL COLECTOMY CPTS" D ^DIE K DA,DIE,DR

 S DA=$O(^BGPTAXS("B","BGP TOTAL CHOLECTOMY CPTS",0))

 I DA S DIE="^BGPTAXS(",DR=".01///"_"BGP TOTAL COLECTOMY CPTS" D ^DIE K DA,DIE,DR

 S DA=$O(^BGPTAXA("B","BGP TOTAL CHOLECTOMY CPTS",0))

 I DA S DIE="^BGPTAXA(",DR=".01///"_"BGP TOTAL COLECTOMY CPTS" D ^DIE K DA,DIE,DR

 S DA=$O(^BGPTAXE("B","BGP TOTAL CHOLECTOMY CPTS",0))

 I DA S DIE="^BGPTAXE(",DR=".01///"_"BGP TOTAL COLECTOMY CPTS" D ^DIE K DA,DIE,DR

 ;

 S ATXFLG=1

 K ^TMP("ATX",$J)

MT ;MOVE TEMPORARY TAXONOMIES TO ATXAX

 S ATXFLG=1

 S BGPX=0 F  S BGPX=$O(^BGPTAXTN(BGPX)) Q:BGPX'=+BGPX  D

 .S BGPN=$P(^BGPTAXTN(BGPX,0),U)

 .S BGPY=$O(^ATXAX("B",BGPN,0))

 .I BGPY S DA=BGPY,DIK="^ATXAX(" D ^DIK

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

 .I Y=-1 W !!,"creating taxonomy failed....",BGPN Q

 .S BGPZ=+Y

 .M ^ATXAX(BGPZ)=^BGPTAXTN(BGPX)

 .I $D(^ATXAX(BGPZ,21,0)) S $P(^ATXAX(BGPZ,21,0),U,2)="9002226.02101A"

 .I $D(^ATXAX(BGPZ,41,0)) S $P(^ATXAX(BGPZ,41,0),U,2)="9002226.04101P"

 .S DA=BGPZ,DIK="^ATXAX(" D IX1^DIK

 .Q

 D ^BGP9YX

 D ^BGP9XX

 D ^BGP9WX

 D ^BGP9VX

 D ^BGP9UX

 D ^BGP9TX

 D ^BGP9SX

 D ^BGP9RX

 D ^BGP9QX

 D ^BGP9OX

 D ^BGP9PX

 D ^BGP9NX

 D LAB^BGP9POS1

 D DRUGS^BGP9POS1

 K ATXFLG

 S X=0 F  S X=$O(^ATXAX(X)) Q:X'=+X  I $E($P($G(^ATXAX(X,0)),U,1),1,3)["BGP" S $P(^ATXAX(X,0),U,4)="n"

 S X=0 F  S X=$O(^ATXLAB(X)) Q:X'=+X  I $E($P($G(^ATXLAB(X,0)),U,1),1,3)["BGP" S $P(^ATXLAB(X,0),U,4)="n"

 D SETTAX

 D SETTAXL

 D SETTAXF

 D SEC

 D EN^XBVK("ATX")

 D EN^XBVK("BGP")

 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 ;

 Q:'$D(^DD(9002226,4101,0))  ;taxonomy patch not yet installed

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

 .S BGPTFIEN=$O(^BGPTAXN("B",BGPTFI,0))

 .I 'BGPTFIEN Q

 .Q:'$D(^BGPTAXN(BGPTFIEN))

 .Q:$P(^BGPTAXN(BGPTFIEN,0),U,2)="L"

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

 .Q:'BGPTDA  ;did not find taxonomy

 .S BGPE=$P(^BGPTAXN(BGPTFIEN,0),U,4)

 .I BGPE=0 S $P(^ATXAX(BGPTDA,0),U,22)=1

 .I BGPE=1 S $P(^ATXAX(BGPTDA,0),U,22)=0

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

 .;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

SETTAXL ;

 Q:'$D(^DD(9002228,4101,0))  ;taxonomy patch not yet installed

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

 .S BGPTFIEN=$O(^BGPTAXN("B",BGPTFI,0))

 .I 'BGPTFIEN Q

 .Q:'$D(^BGPTAXN(BGPTFIEN))

 .Q:$P(^BGPTAXN(BGPTFIEN,0),U,2)='"L"

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

 .Q:'BGPTDA  ;did not find taxonomy

 .S BGPE=$P(^BGPTAXN(BGPTFIEN,0),U,4)

 .I BGPE=0 S $P(^ATXLAB(BGPTDA,0),U,22)=1

 .I BGPE=1 S $P(^ATXLAB(BGPTDA,0),U,22)=0

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

 .;set packages in multiple

 .K DIC,DA,DR

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

 .Q:BGPPI=""  ;NO PACKAGE

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

 .S X="`"_BGPPI,DIC="^ATXLAB("_BGPTDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002228,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

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

CLINICS ;

 ;;01

 ;;06

 ;;13

 ;;20

 ;;24

 ;;28

 ;;

PRVS ;

 ;;00

 ;;11

 ;;16

 ;;17

 ;;18

 ;;21

 ;;25

 ;;33

 ;;41

 ;;44

 ;;45

 ;;49

 ;;64

 ;;68

 ;;69

 ;;70

 ;;71

 ;;72

 ;;73

 ;;74

 ;;75

 ;;76

 ;;77

 ;;78

 ;;79

 ;;80

 ;;81

 ;;82

 ;;83

 ;;84

 ;;85

 ;;86

 ;;A1

 ;;

PREPROV ;;

 ;;00

 ;;08

 ;;11

 ;;16

 ;;17

 ;;18

 ;;21

 ;;24

 ;;25

 ;;30

 ;;33

 ;;41

 ;;44

 ;;45

 ;;47

 ;;49

 ;;64

 ;;67

 ;;68

 ;;70

 ;;71

 ;;72

 ;;73

 ;;74

 ;;75

 ;;76

 ;;77

 ;;78

 ;;79

 ;;80

 ;;81

 ;;82

 ;;83

 ;;85

 ;;86

 ;;A1

 ;;A9

 ;;B1

 ;;B2

 ;;B3

 ;;B4

 ;;B5

 ;;B6

 ;;

SEC ;set security on selected dd's

LP ;EP - loop through file entries

 F I=1:1 D  Q:BGPTXT["end"

 .S BGPTXT=$T(TXT+I)

 .Q:BGPTXT["end"

 .F J=2:1:4 S BGP(J)=$P(BGPTXT,";;",J)

 .S BGP(3)=""""_BGP(3)_""""

 .S BGPREF="^DIC("_BGP(2)_",0,"_BGP(3)_")"

 .S @BGPREF=BGP(4)

 Q

TXT ;file entries start here

 ;;90244.01;;AUDIT;;@

 ;;90244.01;;DD;;@

 ;;90244.01;;DEL;;@

 ;;90244.01;;LAYGO;;@

 ;;90244.01;;RD;;M

 ;;90244.01;;WR;;@

 ;;90244.02;;AUDIT;;@

 ;;90244.02;;DD;;@

 ;;90244.02;;DEL;;@

 ;;90244.02;;LAYGO;;@

 ;;90244.02;;RD;;M

 ;;90244.02;;WR;;@

 ;;90371.04;;AUDIT;;@

 ;;90371.04;;DD;;@

 ;;90371.04;;DEL;;@

 ;;90371.04;;LAYGO;;M

 ;;90371.04;;RD;;M

 ;;90371.04;;WR;;M

 ;;90372.03;;AUDIT;;@

 ;;90372.03;;DD;;@

 ;;90372.03;;DEL;;M

 ;;90372.03;;LAYGO;;M

 ;;90372.03;;RD;;M

 ;;90372.03;;WR;;M

 ;;90372.05;;AUDIT;;@

 ;;90372.05;;DD;;@

 ;;90372.05;;DEL;;M

 ;;90372.05;;LAYGO;;M

 ;;90372.05;;RD;;M

 ;;90372.05;;WR;;M

 ;;90536.12;;AUDIT;;@

 ;;90536.12;;DD;;@

 ;;90536.12;;DEL;;@

 ;;90536.12;;LAYGO;;M

 ;;90536.12;;RD;;M

 ;;90536.12;;WR;;M

 ;;90536.13;;AUDIT;;@

 ;;90536.13;;DD;;@

 ;;90536.13;;DEL;;M

 ;;90536.13;;LAYGO;;M

 ;;90536.13;;RD;;M

 ;;90536.13;;WR;;M

 ;;90536.14;;AUDIT;;@

 ;;90536.14;;DD;;@

 ;;90536.14;;DEL;;M

 ;;90536.14;;LAYGO;;M

 ;;90536.14;;RD;;M

 ;;90536.14;;WR;;M

 ;;end

 Q

BGP9POS   ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM 25 Nov 2007 7:41 PM ; 

 +1       ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009

 +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 '$$INSTALLD("BGP*8.0*3")

               DO SORRY(2)

 +10       QUIT 

 +11      ;

PRE       ;EP

 +1        DO PRE^BGP9POS2

 +2        QUIT 

POST      ;EP - called from kids build

 +1       ;fix 05, 06, 07, 08 mastectomy procedures taxonomies

 +2        SET DA=$ORDER(^BGPTAXV("B","BGP MASTECTOMY PROCEDURES",0))

 +3        IF DA

               SET DIE="^BGPTAXV("

               SET DR=".01///"_"BGP BILAT MASTECT PROCEDURES"

               DO ^DIE

               KILL DA,DIE,DR

 +4        SET DA=$ORDER(^BGPTAXS("B","BGP MASTECTOMY PROCEDURES",0))

 +5        IF DA

               SET DIE="^BGPTAXS("

               SET DR=".01///"_"BGP BILAT MASTECT PROCEDURES"

               DO ^DIE

               KILL DA,DIE,DR

 +6        SET DA=$ORDER(^BGPTAXA("B","BGP MASTECTOMY PROCEDURES",0))

 +7        IF DA

               SET DIE="^BGPTAXA("

               SET DR=".01///"_"BGP BILAT MASTECT PROCEDURES"

               DO ^DIE

               KILL DA,DIE,DR

 +8        SET DA=$ORDER(^BGPTAXE("B","BGP MASTECTOMY PROCEDURES",0))

 +9        IF DA

               SET DIE="^BGPTAXE("

               SET DR=".01///"_"BGP BILAT MASTECT PROCEDURES"

               DO ^DIE

               KILL DA,DIE,DR

 +10       SET DA=$ORDER(^BGPTAXV("B","BGP TOTAL CHOLECTOMY PROCS",0))

 +11       IF DA

               SET DIE="^BGPTAXV("

               SET DR=".01///"_"BGP TOTAL COLECTOMY PROCS"

               DO ^DIE

               KILL DA,DIE,DR

 +12       SET DA=$ORDER(^BGPTAXS("B","BGP TOTAL CHOLECTOMY PROCS",0))

 +13       IF DA

               SET DIE="^BGPTAXS("

               SET DR=".01///"_"BGP TOTAL COLECTOMY PROCS"

               DO ^DIE

               KILL DA,DIE,DR

 +14       SET DA=$ORDER(^BGPTAXA("B","BGP TOTAL CHOLECTOMY PROCS",0))

 +15       IF DA

               SET DIE="^BGPTAXA("

               SET DR=".01///"_"BGP TOTAL COLECTOMY PROCS"

               DO ^DIE

               KILL DA,DIE,DR

 +16       SET DA=$ORDER(^BGPTAXE("B","BGP TOTAL CHOLECTOMY PROCS",0))

 +17       IF DA

               SET DIE="^BGPTAXE("

               SET DR=".01///"_"BGP TOTAL COLECTOMY PROCS"

               DO ^DIE

               KILL DA,DIE,DR

 +18       SET DA=$ORDER(^BGPTAXV("B","BGP TOTAL CHOLECTOMY CPTS",0))

 +19       IF DA

               SET DIE="^BGPTAXV("

               SET DR=".01///"_"BGP TOTAL COLECTOMY CPTS"

               DO ^DIE

               KILL DA,DIE,DR

 +20       SET DA=$ORDER(^BGPTAXS("B","BGP TOTAL CHOLECTOMY CPTS",0))

 +21       IF DA

               SET DIE="^BGPTAXS("

               SET DR=".01///"_"BGP TOTAL COLECTOMY CPTS"

               DO ^DIE

               KILL DA,DIE,DR

 +22       SET DA=$ORDER(^BGPTAXA("B","BGP TOTAL CHOLECTOMY CPTS",0))

 +23       IF DA

               SET DIE="^BGPTAXA("

               SET DR=".01///"_"BGP TOTAL COLECTOMY CPTS"

               DO ^DIE

               KILL DA,DIE,DR

 +24       SET DA=$ORDER(^BGPTAXE("B","BGP TOTAL CHOLECTOMY CPTS",0))

 +25       IF DA

               SET DIE="^BGPTAXE("

               SET DR=".01///"_"BGP TOTAL COLECTOMY CPTS"

               DO ^DIE

               KILL DA,DIE,DR

 +26      ;

 +27       SET ATXFLG=1

 +28       KILL ^TMP("ATX",$JOB)

MT        ;MOVE TEMPORARY TAXONOMIES TO ATXAX

 +1        SET ATXFLG=1

 +2        SET BGPX=0

           FOR 

               SET BGPX=$ORDER(^BGPTAXTN(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               Begin DoDot:1

 +3                SET BGPN=$PIECE(^BGPTAXTN(BGPX,0),U)

 +4                SET BGPY=$ORDER(^ATXAX("B",BGPN,0))

 +5                IF BGPY

                       SET DA=BGPY

                       SET DIK="^ATXAX("

                       DO ^DIK

 +6                SET X=BGPN

                   SET DIC="^ATXAX("

                   SET DIC(0)="L"

                   SET DIADD=1

                   SET DLAYGO=9002226

                   DO ^DIC

                   KILL DIC,DA,DIADD,DLAYGO,I

 +7                IF Y=-1

                       WRITE !!,"creating taxonomy failed....",BGPN

                       QUIT 

 +8                SET BGPZ=+Y

 +9                MERGE ^ATXAX(BGPZ)=^BGPTAXTN(BGPX)

 +10               IF $DATA(^ATXAX(BGPZ,21,0))

                       SET $PIECE(^ATXAX(BGPZ,21,0),U,2)="9002226.02101A"

 +11               IF $DATA(^ATXAX(BGPZ,41,0))

                       SET $PIECE(^ATXAX(BGPZ,41,0),U,2)="9002226.04101P"

 +12               SET DA=BGPZ

                   SET DIK="^ATXAX("

                   DO IX1^DIK

 +13               QUIT 

               End DoDot:1

 +14       DO ^BGP9YX

 +15       DO ^BGP9XX

 +16       DO ^BGP9WX

 +17       DO ^BGP9VX

 +18       DO ^BGP9UX

 +19       DO ^BGP9TX

 +20       DO ^BGP9SX

 +21       DO ^BGP9RX

 +22       DO ^BGP9QX

 +23       DO ^BGP9OX

 +24       DO ^BGP9PX

 +25       DO ^BGP9NX

 +26       DO LAB^BGP9POS1

 +27       DO DRUGS^BGP9POS1

 +28       KILL ATXFLG

 +29       SET X=0

           FOR 

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

               IF X'=+X

                   QUIT 

               IF $EXTRACT($PIECE($GET(^ATXAX(X,0)),U,1),1,3)["BGP"

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

 +30       SET X=0

           FOR 

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

               IF X'=+X

                   QUIT 

               IF $EXTRACT($PIECE($GET(^ATXLAB(X,0)),U,1),1,3)["BGP"

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

 +31       DO SETTAX

 +32       DO SETTAXL

 +33       DO SETTAXF

 +34       DO SEC

 +35       DO EN^XBVK("ATX")

 +36       DO EN^XBVK("BGP")

 +37       QUIT 

 +38      ;

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       ;taxonomy patch not yet installed

           IF '$DATA(^DD(9002226,4101,0))

               QUIT 

 +2        SET BGPTFI=""

           FOR 

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

               IF BGPTFI=""

                   QUIT 

               Begin DoDot:1

 +3                SET BGPTFIEN=$ORDER(^BGPTAXN("B",BGPTFI,0))

 +4                IF 'BGPTFIEN

                       QUIT 

 +5                IF '$DATA(^BGPTAXN(BGPTFIEN))

                       QUIT 

 +6                IF $PIECE(^BGPTAXN(BGPTFIEN,0),U,2)="L"

                       QUIT 

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

 +8       ;did not find taxonomy

                   IF 'BGPTDA

                       QUIT 

 +9                SET BGPE=$PIECE(^BGPTAXN(BGPTFIEN,0),U,4)

 +10               IF BGPE=0

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

 +11               IF BGPE=1

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

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

 +13      ;set packages in multiple

 +14               KILL DIC,DA,DR

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

 +16      ;NO PACKAGE

                   IF BGPPI=""

                       QUIT 

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

                       QUIT 

 +18               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

 +19               DO ^DIC

 +20               IF Y=-1

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

 +21               KILL DIC,DA,Y,X

 +22               QUIT 

               End DoDot:1

 +23       QUIT 

SETTAXL   ;

 +1       ;taxonomy patch not yet installed

           IF '$DATA(^DD(9002228,4101,0))

               QUIT 

 +2        SET BGPTFI=""

           FOR 

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

               IF BGPTFI=""

                   QUIT 

               Begin DoDot:1

 +3                SET BGPTFIEN=$ORDER(^BGPTAXN("B",BGPTFI,0))

 +4                IF 'BGPTFIEN

                       QUIT 

 +5                IF '$DATA(^BGPTAXN(BGPTFIEN))

                       QUIT 

 +6                IF $PIECE(^BGPTAXN(BGPTFIEN,0),U,2)='"L"

                       QUIT 

 +7                SET BGPTDA=$ORDER(^ATXLAB("B",BGPTFI,0))

 +8       ;did not find taxonomy

                   IF 'BGPTDA

                       QUIT 

 +9                SET BGPE=$PIECE(^BGPTAXN(BGPTFIEN,0),U,4)

 +10               IF BGPE=0

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

 +11               IF BGPE=1

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

 +12               SET $PIECE(^ATXLAB(BGPTDA,0),U,4)="n"

 +13      ;set packages in multiple

 +14               KILL DIC,DA,DR

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

 +16      ;NO PACKAGE

                   IF BGPPI=""

                       QUIT 

 +17               IF $DATA(^ATXLAB(BGPTDA,41,"B",BGPPI))

                       QUIT 

 +18               SET X="`"_BGPPI

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

                   SET DIC(0)="L"

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

                   SET DA(1)=BGPTDA

 +19               DO ^DIC

 +20               IF Y=-1

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

 +21               KILL DIC,DA,Y,X

 +22               QUIT 

               End DoDot:1

 +23       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 

CLINICS   ;

 +1       ;;01

 +2       ;;06

 +3       ;;13

 +4       ;;20

 +5       ;;24

 +6       ;;28

 +7       ;;

PRVS      ;

 +1       ;;00

 +2       ;;11

 +3       ;;16

 +4       ;;17

 +5       ;;18

 +6       ;;21

 +7       ;;25

 +8       ;;33

 +9       ;;41

 +10      ;;44

 +11      ;;45

 +12      ;;49

 +13      ;;64

 +14      ;;68

 +15      ;;69

 +16      ;;70

 +17      ;;71

 +18      ;;72

 +19      ;;73

 +20      ;;74

 +21      ;;75

 +22      ;;76

 +23      ;;77

 +24      ;;78

 +25      ;;79

 +26      ;;80

 +27      ;;81

 +28      ;;82

 +29      ;;83

 +30      ;;84

 +31      ;;85

 +32      ;;86

 +33      ;;A1

 +34      ;;

PREPROV   ;;

 +1       ;;00

 +2       ;;08

 +3       ;;11

 +4       ;;16

 +5       ;;17

 +6       ;;18

 +7       ;;21

 +8       ;;24

 +9       ;;25

 +10      ;;30

 +11      ;;33

 +12      ;;41

 +13      ;;44

 +14      ;;45

 +15      ;;47

 +16      ;;49

 +17      ;;64

 +18      ;;67

 +19      ;;68

 +20      ;;70

 +21      ;;71

 +22      ;;72

 +23      ;;73

 +24      ;;74

 +25      ;;75

 +26      ;;76

 +27      ;;77

 +28      ;;78

 +29      ;;79

 +30      ;;80

 +31      ;;81

 +32      ;;82

 +33      ;;83

 +34      ;;85

 +35      ;;86

 +36      ;;A1

 +37      ;;A9

 +38      ;;B1

 +39      ;;B2

 +40      ;;B3

 +41      ;;B4

 +42      ;;B5

 +43      ;;B6

 +44      ;;

SEC       ;set security on selected dd's

LP        ;EP - loop through file entries

 +1        FOR I=1:1

               Begin DoDot:1

 +2                SET BGPTXT=$TEXT(TXT+I)

 +3                IF BGPTXT["end"

                       QUIT 

 +4                FOR J=2:1:4

                       SET BGP(J)=$PIECE(BGPTXT,";;",J)

 +5                SET BGP(3)=""""_BGP(3)_""""

 +6                SET BGPREF="^DIC("_BGP(2)_",0,"_BGP(3)_")"

 +7                SET @BGPREF=BGP(4)

               End DoDot:1

               IF BGPTXT["end"

                   QUIT 

 +8        QUIT 

TXT       ;file entries start here

 +1       ;;90244.01;;AUDIT;;@

 +2       ;;90244.01;;DD;;@

 +3       ;;90244.01;;DEL;;@

 +4       ;;90244.01;;LAYGO;;@

 +5       ;;90244.01;;RD;;M

 +6       ;;90244.01;;WR;;@

 +7       ;;90244.02;;AUDIT;;@

 +8       ;;90244.02;;DD;;@

 +9       ;;90244.02;;DEL;;@

 +10      ;;90244.02;;LAYGO;;@

 +11      ;;90244.02;;RD;;M

 +12      ;;90244.02;;WR;;@

 +13      ;;90371.04;;AUDIT;;@

 +14      ;;90371.04;;DD;;@

 +15      ;;90371.04;;DEL;;@

 +16      ;;90371.04;;LAYGO;;M

 +17      ;;90371.04;;RD;;M

 +18      ;;90371.04;;WR;;M

 +19      ;;90372.03;;AUDIT;;@

 +20      ;;90372.03;;DD;;@

 +21      ;;90372.03;;DEL;;M

 +22      ;;90372.03;;LAYGO;;M

 +23      ;;90372.03;;RD;;M

 +24      ;;90372.03;;WR;;M

 +25      ;;90372.05;;AUDIT;;@

 +26      ;;90372.05;;DD;;@

 +27      ;;90372.05;;DEL;;M

 +28      ;;90372.05;;LAYGO;;M

 +29      ;;90372.05;;RD;;M

 +30      ;;90372.05;;WR;;M

 +31      ;;90536.12;;AUDIT;;@

 +32      ;;90536.12;;DD;;@

 +33      ;;90536.12;;DEL;;@

 +34      ;;90536.12;;LAYGO;;M

 +35      ;;90536.12;;RD;;M

 +36      ;;90536.12;;WR;;M

 +37      ;;90536.13;;AUDIT;;@

 +38      ;;90536.13;;DD;;@

 +39      ;;90536.13;;DEL;;M

 +40      ;;90536.13;;LAYGO;;M

 +41      ;;90536.13;;RD;;M

 +42      ;;90536.13;;WR;;M

 +43      ;;90536.14;;AUDIT;;@

 +44      ;;90536.14;;DD;;@

 +45      ;;90536.14;;DEL;;M

 +46      ;;90536.14;;LAYGO;;M

 +47      ;;90536.14;;RD;;M

 +48      ;;90536.14;;WR;;M

 +49      ;;end

 +50       QUIT