BGP8P2.m

BGP8P2 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM 25 Nov 2007 7:41 PM ; 01 Jul 2008  8:01 PM

 ;;8.0;IHS CLINICAL REPORTING;**2**;MAR 12, 2008

 ;

 ;

 ;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 $$VERSION^XPDUTL("BGP")'="8.0" D SORRY(2)

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

 Q

 ;

PRE ;EP

 ;CHANGE PACKAGE FILE NAME

 S BGPX=0 F  S BGPX=$O(^BGPEOME(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPEOME(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPEOMIE(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPEOMIE(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPPEIE(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPPEIE(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPELIE(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPELIE(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPELIIE(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPELIIE(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPCMSIE(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPCMSIE(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPNPLE(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPNPLE(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPHEIE(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPHEIE(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPHEIIE(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPHEIIE(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPINDEC(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPINDEC(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPINDE(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPINDE(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPTAXE(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPTAXE(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPCMSME(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPCMSME(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPSCAT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPSCAT(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPICAGE(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPICAGE(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPICACE(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPICACE(" D ^DIK

 F BGPX=1:1:2000 K ^BGPTAXE(BGPX)

 S BGPX=0 F  S BGPX=$O(^BGPTAXTE(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPTAXTE(" D ^DIK

 F BGPX=1:1:2000 K ^BGPTAXTE(BGPX)

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

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

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

 Q

POST ;EP - called from kids build

 ;NEW X

 ;S X=$$ADD^XPDMENU("BGPMENU","BGP 08 MENU","CI08",50)

 ;I 'X W "Attempt to add National GPRA report for GPRA year 2008 option failed.." H 3

 S ATXFLG=1

 D EN^XBVK("ATX")

 K ^TMP("ATX",$J)

 D ^BGP82T

 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 EN^XBVK("BGP")

 D SETTAX

 D SETTAXL

 D SETTAXF

 D SEC

 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(^BGPTAXE("B",BGPTFI)) Q:BGPTFI=""  D

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

 .I 'BGPTFIEN Q

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

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

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

 .Q:'BGPTDA  ;did not find taxonomy

 .S BGPE=$P(^BGPTAXE(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(^BGPTAXE("B",BGPTFI)) Q:BGPTFI=""  D

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

 .I 'BGPTFIEN Q

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

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

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

 .Q:'BGPTDA  ;did not find taxonomy

 .S BGPE=$P(^BGPTAXE(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

 ;;90533.12;;AUDIT;;@

 ;;90533.12;;DD;;@

 ;;90533.12;;DEL;;@

 ;;90533.12;;LAYGO;;M

 ;;90533.12;;RD;;M

 ;;90533.12;;WR;;M

 ;;90533.13;;AUDIT;;@

 ;;90533.13;;DD;;@

 ;;90533.13;;DEL;;M

 ;;90533.13;;LAYGO;;M

 ;;90533.13;;RD;;M

 ;;90533.13;;WR;;M

 ;;90533.14;;AUDIT;;@

 ;;90533.14;;DD;;@

 ;;90533.14;;DEL;;M

 ;;90533.14;;LAYGO;;M

 ;;90533.14;;RD;;M

 ;;90533.14;;WR;;M

 ;;end

 Q

BGP8P2    ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM 25 Nov 2007 7:41 PM ; 01 Jul 2008  8:01 PM

 +1       ;;8.0;IHS CLINICAL REPORTING;**2**;MAR 12, 2008

 +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 $$VERSION^XPDUTL("BGP")'="8.0"

               DO SORRY(2)

 +10       IF '$$INSTALLD("BGP*8.0*1")

               DO SORRY(2)

 +11       QUIT 

 +12      ;

PRE       ;EP

 +1       ;CHANGE PACKAGE FILE NAME

 +2        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPEOME("

               DO ^DIK

 +3        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPEOMIE("

               DO ^DIK

 +4        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPPEIE("

               DO ^DIK

 +5        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPELIE("

               DO ^DIK

 +6        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPELIIE("

               DO ^DIK

 +7        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPCMSIE("

               DO ^DIK

 +8        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPNPLE("

               DO ^DIK

 +9        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPHEIE("

               DO ^DIK

 +10       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPHEIIE("

               DO ^DIK

 +11       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPINDEC("

               DO ^DIK

 +12       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPINDE("

               DO ^DIK

 +13       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPTAXE("

               DO ^DIK

 +14       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPCMSME("

               DO ^DIK

 +15       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPSCAT("

               DO ^DIK

 +16       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPICAGE("

               DO ^DIK

 +17       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPICACE("

               DO ^DIK

 +18       FOR BGPX=1:1:2000

               KILL ^BGPTAXE(BGPX)

 +19       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPTAXTE("

               DO ^DIK

 +20       FOR BGPX=1:1:2000

               KILL ^BGPTAXTE(BGPX)

 +21       SET X=0

           FOR 

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

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +22               IF $DATA(^ATXAX(X,21,0))

                       IF $PIECE(^ATXAX(X,21,0),U,2)'["9002226.02101A"

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

 +23               IF $DATA(^ATXAX(X,41,0))

                       IF $PIECE(^ATXAX(X,41,0),U,2)'["9002226.04101P"

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

               End DoDot:1

 +24       QUIT 

POST      ;EP - called from kids build

 +1       ;NEW X

 +2       ;S X=$$ADD^XPDMENU("BGPMENU","BGP 08 MENU","CI08",50)

 +3       ;I 'X W "Attempt to add National GPRA report for GPRA year 2008 option failed.." H 3

 +4        SET ATXFLG=1

 +5        DO EN^XBVK("ATX")

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

 +7        DO ^BGP82T

 +8        KILL ATXFLG

 +9        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"

 +10       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"

 +11       DO EN^XBVK("BGP")

 +12       DO SETTAX

 +13       DO SETTAXL

 +14       DO SETTAXF

 +15       DO SEC

 +16       QUIT 

 +17      ;

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(^BGPTAXE("B",BGPTFI))

               IF BGPTFI=""

                   QUIT 

               Begin DoDot:1

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

 +4                IF 'BGPTFIEN

                       QUIT 

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

                       QUIT 

 +6                IF $PIECE(^BGPTAXE(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(^BGPTAXE(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(^BGPTAXE("B",BGPTFI))

               IF BGPTFI=""

                   QUIT 

               Begin DoDot:1

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

 +4                IF 'BGPTFIEN

                       QUIT 

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

                       QUIT 

 +6                IF $PIECE(^BGPTAXE(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(^BGPTAXE(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      ;;90533.12;;AUDIT;;@

 +32      ;;90533.12;;DD;;@

 +33      ;;90533.12;;DEL;;@

 +34      ;;90533.12;;LAYGO;;M

 +35      ;;90533.12;;RD;;M

 +36      ;;90533.12;;WR;;M

 +37      ;;90533.13;;AUDIT;;@

 +38      ;;90533.13;;DD;;@

 +39      ;;90533.13;;DEL;;M

 +40      ;;90533.13;;LAYGO;;M

 +41      ;;90533.13;;RD;;M

 +42      ;;90533.13;;WR;;M

 +43      ;;90533.14;;AUDIT;;@

 +44      ;;90533.14;;DD;;@

 +45      ;;90533.14;;DEL;;M

 +46      ;;90533.14;;LAYGO;;M

 +47      ;;90533.14;;RD;;M

 +48      ;;90533.14;;WR;;M

 +49      ;;end

 +50       QUIT