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
