BGP0POS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM 25 Nov 2008 7:41 PM ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
;
;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*9.0*1") D SORRY(2)
I $E($$VERSION^XPDUTL("BMX"),1,3)<"4.0" D MES^XPDUTL($$CJ^XLFSTR("Version 4.0 of BMX is required. Not installed.",80)) D SORRY(2) I 1
E D MES^XPDUTL($$CJ^XLFSTR("Requires BMX v4.0....Present.",80))
Q
;
PRE ;EP
D PRE^BGP0POS2
Q
POST ;EP - called from kids build
D SCHEMA
D ^BGP0TX ;install all taxonomies
D LAB^BGP0POS1
D DRUGS^BGP0POS1
D DMADA
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
SCHEMA ;
S DA=$O(^BMXADO("B","BGP 06 HEDIS INDICATORS",0))
I 'DA D
. D ^XBFMK
. S X="BGP 06 HEDIS INDICATORS"
. S DIC="^BMXADO(",DIC(0)="L",DIADD=1,DLAYGO=90093.99
. K DD,D0,DO
. S DIC("DR")=".02///90375.01"
. D FILE^DICN
. I Y=-1 W !!,"Creating schema failed!! " Q
. S Y=+Y
. S ^BMXADO(Y,1,0)="^90093.991^1^1"
. S ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
. S ^BMXADO(Y,1,"B",.05,1)=""
. S DA=Y,DIK="^BMXADO(" D IX1^DIK
. Q
S DA=$O(^BMXADO("B","BGP 07 HEDIS INDICATORS",0))
I 'DA D
. D ^XBFMK
. S X="BGP 07 HEDIS INDICATORS"
. S DIC="^BMXADO(",DIC(0)="L",DIADD=1,DLAYGO=90093.99
. K DD,D0,DO
. S DIC("DR")=".02///90531.01"
. D FILE^DICN
. I Y=-1 W !!,"Creating schema failed!! " Q
. S Y=+Y
. S ^BMXADO(Y,1,0)="^90093.991^1^1"
. S ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
. S ^BMXADO(Y,1,"B",.05,1)=""
. S DA=Y,DIK="^BMXADO(" D IX1^DIK
. Q
S DA=$O(^BMXADO("B","BGP 08 HEDIS INDICATORS",0))
I 'DA D
. D ^XBFMK
. S X="BGP 08 HEDIS INDICATORS"
. S DIC="^BMXADO(",DIC(0)="L",DIADD=1,DLAYGO=90093.99
. K DD,D0,DO
. S DIC("DR")=".02///90534.01"
. D FILE^DICN
. I Y=-1 W !!,"Creating schema failed!! " Q
. S Y=+Y
. S ^BMXADO(Y,1,0)="^90093.991^1^1"
. S ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
. S ^BMXADO(Y,1,"B",.05,1)=""
. S DA=Y,DIK="^BMXADO(" D IX1^DIK
. Q
S DA=$O(^BMXADO("B","BGP 09 HEDIS INDICATORS",0))
I 'DA D
. D ^XBFMK
. S X="BGP 09 HEDIS INDICATORS"
. S DIC="^BMXADO(",DIC(0)="L",DIADD=1,DLAYGO=90093.99
. K DD,D0,DO
. S DIC("DR")=".02///90537.01"
. D FILE^DICN
. I Y=-1 W !!,"Creating schema failed!! " Q
. S Y=+Y
. S ^BMXADO(Y,1,0)="^90093.991^1^1"
. S ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
. S ^BMXADO(Y,1,"B",.05,1)=""
. S DA=Y,DIK="^BMXADO(" D IX1^DIK
. Q
S DA=$O(^BMXADO("B","BGP 10 HEDIS INDICATORS",0))
I 'DA D
. D ^XBFMK
. S X="BGP 10 HEDIS INDICATORS"
. S DIC="^BMXADO(",DIC(0)="L",DIADD=1,DLAYGO=90093.99
. K DD,D0,DO
. S DIC("DR")=".02///90378.01"
. D FILE^DICN
. I Y=-1 W !!,"Creating schema failed!! " Q
. S Y=+Y
. S ^BMXADO(Y,1,0)="^90093.991^1^1"
. S ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
. S ^BMXADO(Y,1,"B",.05,1)=""
. S DA=Y,DIK="^BMXADO(" D IX1^DIK
. Q
Q
DMADA ;
S ATXFLG=1
S BGPDA=0 S BGPDA=$O(^ATXAX("B","BGP TOPICAL FLUORIDE ADA CODES",BGPDA))
I BGPDA S DIK="^ATXAX(",DA=BGPDA D ^DIK ;get rid of existing one
W !,"Creating/Updating Topical Fluoride ADA Codes Taxonomy..."
S X="BGP TOPICAL FLUORIDE 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 TOPICAL FLUORIDE ADA CODES TAX" Q
S BGPTX=+Y,$P(^ATXAX(BGPTX,0),U,2)="BGP TOPICAL FLUORIDE 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=1201,1203,1204,1205,1206,5986 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 ;
Q:'$D(^DD(9002226,4101,0)) ;taxonomy patch not yet installed
S BGPTFI="" F S BGPTFI=$O(^BGPTAXT("B",BGPTFI)) Q:BGPTFI="" D
.S BGPTFIEN=$O(^BGPTAXT("B",BGPTFI,0))
.I 'BGPTFIEN Q
.Q:'$D(^BGPTAXT(BGPTFIEN))
.Q:$P(^BGPTAXT(BGPTFIEN,0),U,2)="L"
.S BGPTDA=$O(^ATXAX("B",BGPTFI,0))
.Q:'BGPTDA ;did not find taxonomy
.S BGPE=$P(^BGPTAXT(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(^BGPTAXT("B",BGPTFI)) Q:BGPTFI="" D
.S BGPTFIEN=$O(^BGPTAXT("B",BGPTFI,0))
.I 'BGPTFIEN Q
.Q:'$D(^BGPTAXT(BGPTFIEN))
.Q:$P(^BGPTAXT(BGPTFIEN,0),U,2)='"L"
.S BGPTDA=$O(^ATXLAB("B",BGPTFI,0))
.Q:'BGPTDA ;did not find taxonomy
.S BGPE=$P(^BGPTAXT(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
;;90377.12;;AUDIT;;@
;;90377.12;;DD;;@
;;90377.12;;DEL;;@
;;90377.12;;LAYGO;;M
;;90377.12;;RD;;M
;;90377.12;;WR;;M
;;90377.13;;AUDIT;;@
;;90377.13;;DD;;@
;;90377.13;;DEL;;M
;;90377.13;;LAYGO;;M
;;90377.13;;RD;;M
;;90377.13;;WR;;M
;;90377.14;;AUDIT;;@
;;90377.14;;DD;;@
;;90377.14;;DEL;;M
;;90377.14;;LAYGO;;M
;;90377.14;;RD;;M
;;90377.14;;WR;;M
;;end
Q
BGP0POS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM 25 Nov 2008 7:41 PM ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+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*9.0*1")
DO SORRY(2)
+10 IF $EXTRACT($$VERSION^XPDUTL("BMX"),1,3)<"4.0"
DO MES^XPDUTL($$CJ^XLFSTR("Version 4.0 of BMX is required. Not installed.",80))
DO SORRY(2)
IF 1
+11 IF '$TEST
DO MES^XPDUTL($$CJ^XLFSTR("Requires BMX v4.0....Present.",80))
+12 QUIT
+13 ;
PRE ;EP
+1 DO PRE^BGP0POS2
+2 QUIT
POST ;EP - called from kids build
+1 DO SCHEMA
+2 ;install all taxonomies
DO ^BGP0TX
+3 DO LAB^BGP0POS1
+4 DO DRUGS^BGP0POS1
+5 DO DMADA
+6 KILL ATXFLG
+7 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"
+8 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"
+9 DO SETTAX
+10 DO SETTAXL
+11 DO SETTAXF
+12 DO SEC
+13 DO EN^XBVK("ATX")
+14 DO EN^XBVK("BGP")
+15 QUIT
SCHEMA ;
+1 SET DA=$ORDER(^BMXADO("B","BGP 06 HEDIS INDICATORS",0))
+2 IF 'DA
Begin DoDot:1
+3 DO ^XBFMK
+4 SET X="BGP 06 HEDIS INDICATORS"
+5 SET DIC="^BMXADO("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=90093.99
+6 KILL DD,D0,DO
+7 SET DIC("DR")=".02///90375.01"
+8 DO FILE^DICN
+9 IF Y=-1
WRITE !!,"Creating schema failed!! "
QUIT
+10 SET Y=+Y
+11 SET ^BMXADO(Y,1,0)="^90093.991^1^1"
+12 SET ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
+13 SET ^BMXADO(Y,1,"B",.05,1)=""
+14 SET DA=Y
SET DIK="^BMXADO("
DO IX1^DIK
+15 QUIT
End DoDot:1
+16 SET DA=$ORDER(^BMXADO("B","BGP 07 HEDIS INDICATORS",0))
+17 IF 'DA
Begin DoDot:1
+18 DO ^XBFMK
+19 SET X="BGP 07 HEDIS INDICATORS"
+20 SET DIC="^BMXADO("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=90093.99
+21 KILL DD,D0,DO
+22 SET DIC("DR")=".02///90531.01"
+23 DO FILE^DICN
+24 IF Y=-1
WRITE !!,"Creating schema failed!! "
QUIT
+25 SET Y=+Y
+26 SET ^BMXADO(Y,1,0)="^90093.991^1^1"
+27 SET ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
+28 SET ^BMXADO(Y,1,"B",.05,1)=""
+29 SET DA=Y
SET DIK="^BMXADO("
DO IX1^DIK
+30 QUIT
End DoDot:1
+31 SET DA=$ORDER(^BMXADO("B","BGP 08 HEDIS INDICATORS",0))
+32 IF 'DA
Begin DoDot:1
+33 DO ^XBFMK
+34 SET X="BGP 08 HEDIS INDICATORS"
+35 SET DIC="^BMXADO("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=90093.99
+36 KILL DD,D0,DO
+37 SET DIC("DR")=".02///90534.01"
+38 DO FILE^DICN
+39 IF Y=-1
WRITE !!,"Creating schema failed!! "
QUIT
+40 SET Y=+Y
+41 SET ^BMXADO(Y,1,0)="^90093.991^1^1"
+42 SET ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
+43 SET ^BMXADO(Y,1,"B",.05,1)=""
+44 SET DA=Y
SET DIK="^BMXADO("
DO IX1^DIK
+45 QUIT
End DoDot:1
+46 SET DA=$ORDER(^BMXADO("B","BGP 09 HEDIS INDICATORS",0))
+47 IF 'DA
Begin DoDot:1
+48 DO ^XBFMK
+49 SET X="BGP 09 HEDIS INDICATORS"
+50 SET DIC="^BMXADO("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=90093.99
+51 KILL DD,D0,DO
+52 SET DIC("DR")=".02///90537.01"
+53 DO FILE^DICN
+54 IF Y=-1
WRITE !!,"Creating schema failed!! "
QUIT
+55 SET Y=+Y
+56 SET ^BMXADO(Y,1,0)="^90093.991^1^1"
+57 SET ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
+58 SET ^BMXADO(Y,1,"B",.05,1)=""
+59 SET DA=Y
SET DIK="^BMXADO("
DO IX1^DIK
+60 QUIT
End DoDot:1
+61 SET DA=$ORDER(^BMXADO("B","BGP 10 HEDIS INDICATORS",0))
+62 IF 'DA
Begin DoDot:1
+63 DO ^XBFMK
+64 SET X="BGP 10 HEDIS INDICATORS"
+65 SET DIC="^BMXADO("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=90093.99
+66 KILL DD,D0,DO
+67 SET DIC("DR")=".02///90378.01"
+68 DO FILE^DICN
+69 IF Y=-1
WRITE !!,"Creating schema failed!! "
QUIT
+70 SET Y=+Y
+71 SET ^BMXADO(Y,1,0)="^90093.991^1^1"
+72 SET ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
+73 SET ^BMXADO(Y,1,"B",.05,1)=""
+74 SET DA=Y
SET DIK="^BMXADO("
DO IX1^DIK
+75 QUIT
End DoDot:1
+76 QUIT
DMADA ;
+1 SET ATXFLG=1
+2 SET BGPDA=0
SET BGPDA=$ORDER(^ATXAX("B","BGP TOPICAL FLUORIDE ADA CODES",BGPDA))
+3 ;get rid of existing one
IF BGPDA
SET DIK="^ATXAX("
SET DA=BGPDA
DO ^DIK
+4 WRITE !,"Creating/Updating Topical Fluoride ADA Codes Taxonomy..."
+5 SET X="BGP TOPICAL FLUORIDE 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 TOPICAL FLUORIDE ADA CODES TAX"
QUIT
+7 SET BGPTX=+Y
SET $PIECE(^ATXAX(BGPTX,0),U,2)="BGP TOPICAL FLUORIDE 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=1201,1203,1204,1205,1206,5986
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
+15 ;
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(^BGPTAXT("B",BGPTFI))
IF BGPTFI=""
QUIT
Begin DoDot:1
+3 SET BGPTFIEN=$ORDER(^BGPTAXT("B",BGPTFI,0))
+4 IF 'BGPTFIEN
QUIT
+5 IF '$DATA(^BGPTAXT(BGPTFIEN))
QUIT
+6 IF $PIECE(^BGPTAXT(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(^BGPTAXT(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(^BGPTAXT("B",BGPTFI))
IF BGPTFI=""
QUIT
Begin DoDot:1
+3 SET BGPTFIEN=$ORDER(^BGPTAXT("B",BGPTFI,0))
+4 IF 'BGPTFIEN
QUIT
+5 IF '$DATA(^BGPTAXT(BGPTFIEN))
QUIT
+6 IF $PIECE(^BGPTAXT(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(^BGPTAXT(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 ;;90377.12;;AUDIT;;@
+32 ;;90377.12;;DD;;@
+33 ;;90377.12;;DEL;;@
+34 ;;90377.12;;LAYGO;;M
+35 ;;90377.12;;RD;;M
+36 ;;90377.12;;WR;;M
+37 ;;90377.13;;AUDIT;;@
+38 ;;90377.13;;DD;;@
+39 ;;90377.13;;DEL;;M
+40 ;;90377.13;;LAYGO;;M
+41 ;;90377.13;;RD;;M
+42 ;;90377.13;;WR;;M
+43 ;;90377.14;;AUDIT;;@
+44 ;;90377.14;;DD;;@
+45 ;;90377.14;;DEL;;M
+46 ;;90377.14;;LAYGO;;M
+47 ;;90377.14;;RD;;M
+48 ;;90377.14;;WR;;M
+49 ;;end
+50 QUIT
