BGP31POS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 08 Dec 2010 3:10 PM ;
;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
;
;
;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^BGP3POS2
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 ^BGP3Y
;D ^BGP3W
;D ^BGP3V
;D ^BGP3T
;D DRUGS^BGP3POS1
;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
BGP31POS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 08 Dec 2010 3:10 PM ;
+1 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
+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 ;D PRE^BGP3POS2
+2 QUIT
POST ;EP - called from kids build
+1 ;D ^BGP21
+2 ;D ^BGP22
+3 ;D ^BGP23
+4 ;D ^BGP24
+5 ;D ^BGP25
+6 ;D ^BGP26
+7 ;D ^BGP27
+8 ;D ^BGP28
+9 ;D ^BGP29
+10 ;D ^BGP20
+11 ;D ^BGP3Y
+12 ;D ^BGP3W
+13 ;D ^BGP3V
+14 ;D ^BGP3T
+15 ;D DRUGS^BGP3POS1
+16 ;D ADA
+17 ;D SETTAXF
+18 ;D 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
