BGP5POS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 08 Dec 2010 3:10 PM ; 04 Aug 2015 2:27 PM
;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
;
;
;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
; '$$INSTALLD("BGP*14.1*1") D SORRY(2)
I +$$VERSION^XPDUTL("BGP")<15.0 D MES^XPDUTL($$CJ^XLFSTR("Version 15.0 of the IHS CLINICAL REPORTING is required. Not installed",80)) D SORRY(2) I 1
Q
;
PRE ;EP
;WIPE OUT CHS AND URBAN PARAMETERS, FIELDS ARE BEING DELETED
S BGPX=0 F S BGPX=$O(^BGPSITE(BGPX)) Q:BGPX'=+BGPX S DIE="^BGPSITE(",DA=BGPX,DR=".06///@;.08///@" D ^DIE K DA,DR,DIE
D PRE^BGP5POS2
S DA=$O(^DIC(19,"B","BGP 02 MENU",0))
I DA S DIE="^DIC(19,",DR="4///A" D ^DIE
PRE1 ;FIX TAXONOMIES
S DA=$O(^ATXAX("B","BGPMU PREGNANCY ALL ICD",0))
I DA,$P(^ATXAX(DA,0),U,15)="" S DIE="^ATXAX(",DR=".15///80" D ^DIE
S DA=$O(^ATXAX("B","BGPMU CHEMOTHERAPY CPTS",0))
I DA,$P(^ATXAX(DA,0),U,15)="" S DIE="^ATXAX(",DR=".15///81" D ^DIE
Q
POST ;EP - called from kids build
;DELETE OLD 101, LIST TEMPLATES, REMOTE PROCEDURES
;D DELOLD
;D ^BGP50
;D ^BGP51
;D ^BGP52
D ^BGP53
S BGPX=$O(^ATXAX("B","BGP HYSTERECTOMY DXS",0))
I BGPX D
.S BGPY=0 F S BGPY=$O(^ATXAX(BGPX,21,BGPY)) Q:BGPY'=+BGPY D
..I $P(^ATXAX(BGPX,21,BGPY,0),U,1)["V67.01"!($P(^ATXAX(BGPX,21,BGPY,0),U,1)["V76.47") D
...;delete out of multiple
...S DA(1)=BGPX,DA=BGPY,DIK="^ATXAX("_DA(1)_",21," D ^DIK K DIK,DA
S BGPX=$O(^ATXAX("B","BGP FRACTURE DXS",0))
I BGPX D
.S BGPY=0 F S BGPY=$O(^ATXAX(BGPX,21,BGPY)) Q:BGPY'=+BGPY D
..I $P(^ATXAX(BGPX,21,BGPY,0),U,1)["733.1" D
...;delete out of multiple
...S DA(1)=BGPX,DA=BGPY,DIK="^ATXAX("_DA(1)_",21," D ^DIK K DIK,DA
S BGPX=$O(^ATXAX("B","BGP HEPATITIS C DXS",0))
I BGPX D
.NEW BGPY,C,CNT,G
.S BGPY=0,C=0,CNT=0,G=0 F S BGPY=$O(^ATXAX(BGPX,21,BGPY)) Q:BGPY'=+BGPY S C=BGPY,CNT=CNT+1 I $P(^ATXAX(BGPX,21,BGPY,0),U,1)["V02.62" S G=1
.Q:G
.S C=C+1,CNT=CNT+1,^ATXAX(BGPX,21,C,0)="V02.62 ^V02.62 ^1"
.S $P(^ATXAX(BGPX,21,0),U,3)=C
.S $P(^ATXAX(BGPX,21,0),U,4)=CNT
.S DA=C,DIK="^ATXAX(" D IX^DIK
;D ^BGP53
D DRUGS^BGP5POS1
D LAB^BGP5POS1
D BMXPO
D ADA
D NDC
;STUFF VERSION # IN BGP DATA FILES
D S15
Q
S15 ;WIPE OUT ALL 15.0 FILES SO START CLEAN WITH 15.1 FILES
S BGPX=0 F S BGPX=$O(^BGPGPDCK(BGPX)) Q:BGPX'=+BGPX D
.S DA=BGPX,DIK="^BGPGPDCK(" D ^DIK
S BGPX=0 F S BGPX=$O(^BGPGPDPK(BGPX)) Q:BGPX'=+BGPX D
.S DA=BGPX,DIK="^BGPGPDPK(" D ^DIK
S BGPX=0 F S BGPX=$O(^BGPGPDBK(BGPX)) Q:BGPX'=+BGPX D
.S DA=BGPX,DIK="^BGPGPDBK(" D ^DIK
Q
HOLD NEW BGPD,BGPX
S BGPX=$O(^XPD(9.7,"B","IHS CLINICAL REPORTING 15.1",0))
I 'BGPX D Q
.;SET ALL TO 15.0
.S BGPX=0 F S BGPX=$O(^BGPGPDCK(BGPX)) Q:BGPX'=+BGPX D
..Q:'$D(^BGPGPDCK(BGPX,0))
..Q:$P(^BGPGPDCK(BGPX,0),U,21)]""
..S DA=BGPX,DIE="^BGPGPDCK(",DR=".21///15.0" D ^DIE
..S DA=BGPX,DIE="^BGPGPDPK(",DR=".21///15.0" D ^DIE
..S DA=BGPX,DIE="^BGPGPDBK(",DR=".21///15.0" D ^DIE
S BGPD=$P($P(^XPD(9.7,BGPX,0),U,3),".") ;DATE FIRST INSTALLED
;IF DATE CREATED IS BEFORE THIS DATE SET TO 15.0, OTHERWISE SET TO 15.0
S BGPX=0 F S BGPX=$O(^BGPGPDCK(BGPX)) Q:BGPX'=+BGPX D
.S V=""
.Q:'$D(^BGPGPDCK(BGPX,0))
.Q:$P(^BGPGPDCK(BGPX,0),U,21)]""
.I BGPD="" S V="15.0" G S151
.I $P(^BGPGPDCK(BGPX,0),U,13)<BGPD S V="15.0" G S151
.S V="15.1"
S151 .S DA=BGPX,DIE="^BGPGPDCK(",DR=".21///"_V D ^DIE
.S DA=BGPX,DIE="^BGPGPDPK(",DR=".21///"_V D ^DIE
.S DA=BGPX,DIE="^BGPGPDBK(",DR=".21///"_V D ^DIE
Q
NDC ;
S BGPX=0 F S BGPX=$O(^ATXAX(BGPX)) Q:BGPX'=+BGPX D
.Q:$P(^ATXAX(BGPX,0),U,15)]"" ;already has a file
.Q:$P(^ATXAX(BGPX,0),U,1)'["NDC"
.Q:$E($P(^ATXAX(BGPX,0),U,1),1,3)'="BGP"
.S $P(^ATXAX(BGPX,0),U,15)=50.67
.Q
Q
BMXPO ;-- update the RPC file
N BGPRPC
S BGPRPC=$O(^DIC(19,"B","BGPGRPC",0))
Q:'BGPRPC
D CLEAN(BGPRPC)
D GUIEP^BMXPO(.RETVAL,BGPRPC_"|BGP")
D GUIEP^BMXPO(.RETVAL,BGPRPC_"|ATX")
Q
CLEAN(APP) ;-- clean out the RPC multiple first
S DA(1)=APP
S DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","
N BGPDA
S BGPDA=0 F S BGPDA=$O(^DIC(19,APP,"RPC",BGPDA)) Q:'BGPDA D
. S DA=BGPDA
. D ^DIK
K ^DIC(19,APP,"RPC","B")
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 GEN ANESTHESIA ADA CODES",BGPDA))
I BGPDA S DIK="^ATXAX(",DA=BGPDA D ^DIK ;get rid of existing one
W !,"Creating/Updating DENTAL ANESTHESIA ADA Codes Taxonomy..."
S X="BGP GEN ANESTHESIA 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 ANESTHISIZ ADA CODES TAX" Q
S BGPTX=+Y,$P(^ATXAX(BGPTX,0),U,2)="BGP GEN ANESTHESIA 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="9220" 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
;SSC
S BGPDA=0 S BGPDA=$O(^ATXAX("B","BGP SSC ADA CODES",BGPDA))
I BGPDA S DIK="^ATXAX(",DA=BGPDA D ^DIK ;get rid of existing one
W !,"Creating/Updating SSC ADA Codes Taxonomy..."
S X="BGP SSC 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 SSC ADA CODES TAX" Q
S BGPTX=+Y,$P(^ATXAX(BGPTX,0),U,2)="BGP SSC 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=2930,2931 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
BGP5POS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 08 Dec 2010 3:10 PM ; 04 Aug 2015 2:27 PM
+1 ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
+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 ; '$$INSTALLD("BGP*14.1*1") D SORRY(2)
+10 IF +$$VERSION^XPDUTL("BGP")<15.0
DO MES^XPDUTL($$CJ^XLFSTR("Version 15.0 of the IHS CLINICAL REPORTING is required. Not installed",80))
DO SORRY(2)
IF 1
+11 QUIT
+12 ;
PRE ;EP
+1 ;WIPE OUT CHS AND URBAN PARAMETERS, FIELDS ARE BEING DELETED
+2 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPSITE(BGPX))
IF BGPX'=+BGPX
QUIT
SET DIE="^BGPSITE("
SET DA=BGPX
SET DR=".06///@;.08///@"
DO ^DIE
KILL DA,DR,DIE
+3 DO PRE^BGP5POS2
+4 SET DA=$ORDER(^DIC(19,"B","BGP 02 MENU",0))
+5 IF DA
SET DIE="^DIC(19,"
SET DR="4///A"
DO ^DIE
PRE1 ;FIX TAXONOMIES
+1 SET DA=$ORDER(^ATXAX("B","BGPMU PREGNANCY ALL ICD",0))
+2 IF DA
IF $PIECE(^ATXAX(DA,0),U,15)=""
SET DIE="^ATXAX("
SET DR=".15///80"
DO ^DIE
+3 SET DA=$ORDER(^ATXAX("B","BGPMU CHEMOTHERAPY CPTS",0))
+4 IF DA
IF $PIECE(^ATXAX(DA,0),U,15)=""
SET DIE="^ATXAX("
SET DR=".15///81"
DO ^DIE
+5 QUIT
POST ;EP - called from kids build
+1 ;DELETE OLD 101, LIST TEMPLATES, REMOTE PROCEDURES
+2 ;D DELOLD
+3 ;D ^BGP50
+4 ;D ^BGP51
+5 ;D ^BGP52
+6 DO ^BGP53
+7 SET BGPX=$ORDER(^ATXAX("B","BGP HYSTERECTOMY DXS",0))
+8 IF BGPX
Begin DoDot:1
+9 SET BGPY=0
FOR
SET BGPY=$ORDER(^ATXAX(BGPX,21,BGPY))
IF BGPY'=+BGPY
QUIT
Begin DoDot:2
+10 IF $PIECE(^ATXAX(BGPX,21,BGPY,0),U,1)["V67.01"!($PIECE(^ATXAX(BGPX,21,BGPY,0),U,1)["V76.47")
Begin DoDot:3
+11 ;delete out of multiple
+12 SET DA(1)=BGPX
SET DA=BGPY
SET DIK="^ATXAX("_DA(1)_",21,"
DO ^DIK
KILL DIK,DA
End DoDot:3
End DoDot:2
End DoDot:1
+13 SET BGPX=$ORDER(^ATXAX("B","BGP FRACTURE DXS",0))
+14 IF BGPX
Begin DoDot:1
+15 SET BGPY=0
FOR
SET BGPY=$ORDER(^ATXAX(BGPX,21,BGPY))
IF BGPY'=+BGPY
QUIT
Begin DoDot:2
+16 IF $PIECE(^ATXAX(BGPX,21,BGPY,0),U,1)["733.1"
Begin DoDot:3
+17 ;delete out of multiple
+18 SET DA(1)=BGPX
SET DA=BGPY
SET DIK="^ATXAX("_DA(1)_",21,"
DO ^DIK
KILL DIK,DA
End DoDot:3
End DoDot:2
End DoDot:1
+19 SET BGPX=$ORDER(^ATXAX("B","BGP HEPATITIS C DXS",0))
+20 IF BGPX
Begin DoDot:1
+21 NEW BGPY,C,CNT,G
+22 SET BGPY=0
SET C=0
SET CNT=0
SET G=0
FOR
SET BGPY=$ORDER(^ATXAX(BGPX,21,BGPY))
IF BGPY'=+BGPY
QUIT
SET C=BGPY
SET CNT=CNT+1
IF $PIECE(^ATXAX(BGPX,21,BGPY,0),U,1)["V02.62"
SET G=1
+23 IF G
QUIT
+24 SET C=C+1
SET CNT=CNT+1
SET ^ATXAX(BGPX,21,C,0)="V02.62 ^V02.62 ^1"
+25 SET $PIECE(^ATXAX(BGPX,21,0),U,3)=C
+26 SET $PIECE(^ATXAX(BGPX,21,0),U,4)=CNT
+27 SET DA=C
SET DIK="^ATXAX("
DO IX^DIK
End DoDot:1
+28 ;D ^BGP53
+29 DO DRUGS^BGP5POS1
+30 DO LAB^BGP5POS1
+31 DO BMXPO
+32 DO ADA
+33 DO NDC
+34 ;STUFF VERSION # IN BGP DATA FILES
+35 DO S15
+36 QUIT
S15 ;WIPE OUT ALL 15.0 FILES SO START CLEAN WITH 15.1 FILES
+1 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPGPDCK(BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:1
+2 SET DA=BGPX
SET DIK="^BGPGPDCK("
DO ^DIK
End DoDot:1
+3 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPGPDPK(BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:1
+4 SET DA=BGPX
SET DIK="^BGPGPDPK("
DO ^DIK
End DoDot:1
+5 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPGPDBK(BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:1
+6 SET DA=BGPX
SET DIK="^BGPGPDBK("
DO ^DIK
End DoDot:1
+7 QUIT
HOLD NEW BGPD,BGPX
+1 SET BGPX=$ORDER(^XPD(9.7,"B","IHS CLINICAL REPORTING 15.1",0))
+2 IF 'BGPX
Begin DoDot:1
+3 ;SET ALL TO 15.0
+4 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPGPDCK(BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+5 IF '$DATA(^BGPGPDCK(BGPX,0))
QUIT
+6 IF $PIECE(^BGPGPDCK(BGPX,0),U,21)]""
QUIT
+7 SET DA=BGPX
SET DIE="^BGPGPDCK("
SET DR=".21///15.0"
DO ^DIE
+8 SET DA=BGPX
SET DIE="^BGPGPDPK("
SET DR=".21///15.0"
DO ^DIE
+9 SET DA=BGPX
SET DIE="^BGPGPDBK("
SET DR=".21///15.0"
DO ^DIE
End DoDot:2
End DoDot:1
QUIT
+10 ;DATE FIRST INSTALLED
SET BGPD=$PIECE($PIECE(^XPD(9.7,BGPX,0),U,3),".")
+11 ;IF DATE CREATED IS BEFORE THIS DATE SET TO 15.0, OTHERWISE SET TO 15.0
+12 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPGPDCK(BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:1
+13 SET V=""
+14 IF '$DATA(^BGPGPDCK(BGPX,0))
QUIT
+15 IF $PIECE(^BGPGPDCK(BGPX,0),U,21)]""
QUIT
+16 IF BGPD=""
SET V="15.0"
GOTO S151
+17 IF $PIECE(^BGPGPDCK(BGPX,0),U,13)<BGPD
SET V="15.0"
GOTO S151
+18 SET V="15.1"
S151 SET DA=BGPX
SET DIE="^BGPGPDCK("
SET DR=".21///"_V
DO ^DIE
+1 SET DA=BGPX
SET DIE="^BGPGPDPK("
SET DR=".21///"_V
DO ^DIE
+2 SET DA=BGPX
SET DIE="^BGPGPDBK("
SET DR=".21///"_V
DO ^DIE
End DoDot:1
+3 QUIT
NDC ;
+1 SET BGPX=0
FOR
SET BGPX=$ORDER(^ATXAX(BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:1
+2 ;already has a file
IF $PIECE(^ATXAX(BGPX,0),U,15)]""
QUIT
+3 IF $PIECE(^ATXAX(BGPX,0),U,1)'["NDC"
QUIT
+4 IF $EXTRACT($PIECE(^ATXAX(BGPX,0),U,1),1,3)'="BGP"
QUIT
+5 SET $PIECE(^ATXAX(BGPX,0),U,15)=50.67
+6 QUIT
End DoDot:1
+7 QUIT
BMXPO ;-- update the RPC file
+1 NEW BGPRPC
+2 SET BGPRPC=$ORDER(^DIC(19,"B","BGPGRPC",0))
+3 IF 'BGPRPC
QUIT
+4 DO CLEAN(BGPRPC)
+5 DO GUIEP^BMXPO(.RETVAL,BGPRPC_"|BGP")
+6 DO GUIEP^BMXPO(.RETVAL,BGPRPC_"|ATX")
+7 QUIT
CLEAN(APP) ;-- clean out the RPC multiple first
+1 SET DA(1)=APP
+2 SET DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","
+3 NEW BGPDA
+4 SET BGPDA=0
FOR
SET BGPDA=$ORDER(^DIC(19,APP,"RPC",BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+5 SET DA=BGPDA
+6 DO ^DIK
End DoDot:1
+7 KILL ^DIC(19,APP,"RPC","B")
+8 QUIT
+9 ;
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 GEN ANESTHESIA ADA CODES",BGPDA))
+3 ;get rid of existing one
IF BGPDA
SET DIK="^ATXAX("
SET DA=BGPDA
DO ^DIK
+4 WRITE !,"Creating/Updating DENTAL ANESTHESIA ADA Codes Taxonomy..."
+5 SET X="BGP GEN ANESTHESIA 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 ANESTHISIZ ADA CODES TAX"
QUIT
+7 SET BGPTX=+Y
SET $PIECE(^ATXAX(BGPTX,0),U,2)="BGP GEN ANESTHESIA 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="9220"
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 ;SSC
+15 SET BGPDA=0
SET BGPDA=$ORDER(^ATXAX("B","BGP SSC ADA CODES",BGPDA))
+16 ;get rid of existing one
IF BGPDA
SET DIK="^ATXAX("
SET DA=BGPDA
DO ^DIK
+17 WRITE !,"Creating/Updating SSC ADA Codes Taxonomy..."
+18 SET X="BGP SSC ADA CODES"
SET DIC="^ATXAX("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002226
DO ^DIC
KILL DIC,DA,DIADD,DLAYGO,I
+19 IF Y=-1
WRITE !!,"ERROR IN CREATING SSC ADA CODES TAX"
QUIT
+20 SET BGPTX=+Y
SET $PIECE(^ATXAX(BGPTX,0),U,2)="BGP SSC 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"
+21 SET BGPX=0
+22 FOR X=2930,2931
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
+23 SET BGPX=BGPX+1
+24 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)=""
+25 QUIT
End DoDot:1
+26 SET DA=BGPTX
SET DIK="^ATXAX("
DO IX1^DIK
+27 QUIT
