BUDEENV ;IHS/CMI/LAB - environmental check post init;
;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
;
ENV ;
; 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")'>"17" D MES^XPDUTL($$CJ^XLFSTR("Version 17.1 of CRS (BGP) is required. Not installed",80)) D SORRY(2)
I $$VERSION^XPDUTL("BUD")'>10.9 D MES^XPDUTL($$CJ^XLFSTR("Version 11.0 of UDS (BUD) is required. Not installed",80)) D SORRY(2)
Q
;
;
PRE ;
;ADD ALL OTHERS BACK IN
;edit package name
S DA=$O(^DIC(9.4,"C","BUD",0))
I DA S DIE="^DIC(9.4,",DR=".01///IHS/RPMS UNIFORM DATA SYS" D ^DIE K DA,DIE
F DA=1:1:50 S DIK="^BUDECNTL(" D ^DIK
F DA=1:1:50 S DIK="^BUDEIL(" D ^DIK
F DA=1:1:50 S DIK="^BUDETFIV(" D ^DIK
F DA=1:1:50 S DIK="^BUDETTA(" D ^DIK
F DA=1:1:50 S DIK="^BUDELST2(" D ^DIK
F DA=1:1:999 S DIK="^BUDETSC(" D ^DIK
F DA=1:1:999 S DIK="^BUDETSSC(" D ^DIK
Q
POST ;
;move site parameters from 04 to 05 on first time install only
I '$O(^BUDESITE(0)) D
.S BUDX=0 F S BUDX=$O(^BUDDSITE(BUDX)) Q:BUDX'=+BUDX D
..M ^BUDESITE(BUDX)=^BUDDSITE(BUDX)
..S DA=BUDX,DIK="^BUDESITE(" D IX1^DIK
;create and populate drug taxonomy
D ^BUDE1
D ^BUDE2
D DRUG
D LAB
D SETICD
Q
SETICD ;
;NOW DO TABLE 6B/7 LISTS
DX ;DX 11 NODE
S BUDX=0 F S BUDX=$O(^BUDETSSC(BUDX)) Q:BUDX'=+BUDX D
.S BUDY=0 F S BUDY=$O(^BUDETSSC(BUDX,11,BUDY)) Q:BUDY'=+BUDY D
..F X=2,3 S $P(^BUDETSSC(BUDX,11,BUDY,0),U,X)=""
K ^BUDETSSC("AD")
S BUDX=0 F S BUDX=$O(^BUDETSSC(BUDX)) Q:BUDX'=+BUDX D
.S BUDY=0 F S BUDY=$O(^BUDETSSC(BUDX,11,BUDY)) Q:BUDY'=+BUDY D
..S I=$P(^BUDETSSC(BUDX,11,BUDY,0),U,1)
..S I=$$ICDDX^ICDEX(I,DT)
..S $P(^BUDETSSC(BUDX,11,BUDY,0),U,2)=$P(I,U,1)
..S $P(^BUDETSSC(BUDX,11,BUDY,0),U,3)=$P(I,U,20)
;S DIK="^BUDETSSC(" D IXALL^DIK
;PROC
S BUDX=0 F S BUDX=$O(^BUDETSSC(BUDX)) Q:BUDX'=+BUDX D
.S BUDY=0 F S BUDY=$O(^BUDETSSC(BUDX,12,BUDY)) Q:BUDY'=+BUDY D
..F X=2,3 S $P(^BUDETSSC(BUDX,12,BUDY,0),U,X)=""
K ^BUDETSSC("AP")
S BUDX=0 F S BUDX=$O(^BUDETSSC(BUDX)) Q:BUDX'=+BUDX D
.S BUDY=0 F S BUDY=$O(^BUDETSSC(BUDX,12,BUDY)) Q:BUDY'=+BUDY D
..S I=$P(^BUDETSSC(BUDX,12,BUDY,0),U,1)
..S I=$$ICDOP^ICDEX(I,DT)
..S $P(^BUDETSSC(BUDX,12,BUDY,0),U,2)=$P(I,U,1)
..S $P(^BUDETSSC(BUDX,12,BUDY,0),U,3)=$P(I,U,15)
S DIK="^BUDETSSC(" D IXALL^DIK
Q
LAB ;EP
S BUDX="BGP HIV TEST TAX" D LAB1
S BUDX="BGP CD4 TAX" D LAB1
S BUDX="BGP HIV VIRAL LOAD TAX" D LAB1
Q
LAB1 ;
S BUDDA=$O(^ATXLAB("B",BUDX,0))
Q:BUDDA ;taxonomy already exisits
W !,"Creating ",BUDX," Taxonomy..."
S X=BUDX,DIC="^ATXLAB(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I
I Y=-1 W !!,"ERROR IN CREATING ",BUDX," TAX" Q
S BUDTX=+Y,$P(^ATXLAB(BUDTX,0),U,2)=BUDX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="B",$P(^(0),U,9)=60
S ^ATXLAB(BUDTX,21,0)="^9002228.02101PA^0^0"
S DA=BUDTX,DIK="^ATXAX(" D IX1^DIK
Q
;
INSTALLD(BUDSTAL) ;EP - Determine if patch BUDSTAL was installed, where
; BUDSTAL is the name of the INSTALL. E.g "AG*6.0*11".
;
NEW BUDY,DIC,X,Y
S X=$P(BUDSTAL,"*",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(BUDSTAL,"*",2)
D ^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(BUDSTAL,"*",3)
D ^DIC
S BUDY=Y
D IMES
Q $S(BUDY<1:0,1:1)
IMES ;
D MES^XPDUTL($$CJ^XLFSTR("Patch """_BUDSTAL_""" 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
DRUG ;EP set up drug taxonomies
S ATXFLG=1
S BUDX="BUD DIABETES MEDS TAX",BUDTAX="",BUDNDCT="BUD DIABETES MEDS NDC" D DRUG1
S BUDX="BGP PQA CONTROLLER MEDS",BUDTAX="",BUDNDCT="BGP PQA CONTROLLER NDC" D DRUG1
S BUDX="BGP HEDIS ANTIDEPRESSANT MEDS",BUDTAX="",BUDNDCT="BGP HEDIS ANTIDEPRESSANT NDC" D DRUG1
S BUDX="BGP PQA SABA MEDS",BUDTAX="",BUDNDCT="BGP PQA SABA NDC" D DRUG1
S BUDX="BUD LIPID LOWERING MEDS",BUDTAX="",BUDNDCT="BGPMU LIPID LOWERING NDCS" D DRUG1
S BUDX="BUD ANTIPLATELET MEDS",BUDTAX="",BUDNDCT="BGPMU IVD ANTIPLATELET NDCS" D DRUG1
S BUDX="BGP HEDIS ANTIDEPRESSANT MEDS",BUDTAX="",BUDNDCT="BGP HEDIS ANTIDEPRESSANT NDC" D DRUG1
S BUDX="BGP PQA WARFARIN MEDS",BUDTAX="",BUDNDCT="BGP PQA WARFARIN NDC" D DRUG1
S BUDX="BGP PQA NON-WARF ANTICOAG MEDS",BUDTAX="",BUDNDCT="BGP PQA NON-WARF ANTICOAG NDC" D DRUG1
K ATXFLG,BUDX,BUDDA,BUDTX,BUDNDCT,BUDTAX
Q
DRUG1 ;
W !,"Creating ",BUDX," Taxonomy..."
S BUDTX=$O(^ATXAX("B",BUDX,0))
I 'BUDTX D Q:Y=-1
.S X=BUDX,DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I
.I Y=-1 W !!,"ERROR IN CREATING ",BUDX," TAX" Q
.S BUDTX=+Y,$P(^ATXAX(BUDTX,0),U,2)=BUDX,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=173,$P(^(0),U,13)=0,$P(^(0),U,15)=50,^ATXAX(BUDTX,21,0)="^9002226.02101A^0^0"
S DA=BUDTX,DIK="^ATXAX(" D IX1^DIK
I $G(BUDTAX)]"" D
.S A=0,B="" F S A=$O(^ATXAX(BUDTX,21,A)) Q:A'=+A S B=A
.S BUDD=B
.S ^ATXAX(BUDTX,21,0)="^9002226.02101A^"_B_U_B
.S Z=$O(^ATXAX("B",BUDTAX,0))
.S J=0 F S J=$O(^PSDRUG(J)) Q:J'=+J S C=$P($G(^PSDRUG(J,0)),U,2) I C]"",$D(^ATXAX(Z,21,"B",C)) D
..Q:$D(^ATXAX(BUDTX,21,"B",J))
..S BUDD=BUDD+1,^ATXAX(BUDTX,21,BUDD,0)=J_U_J
I $G(BUDNDCT)]"" D
.S A=0,B="" F S A=$O(^ATXAX(BUDTX,21,A)) Q:A'=+A S B=A
.S BUDD=B
.S ^ATXAX(BUDTX,21,0)="^9002226.02101A^"_B_U_B
.S Z=$O(^ATXAX("B",BUDNDCT,0))
.S J=0 F S J=$O(^PSDRUG(J)) Q:J'=+J D
..S G=0
..S C=$P($G(^PSDRUG(J,2)),U,4)
..I C]"",$D(^ATXAX(Z,21,"B",$$STRIP^XLFSTR(C,"-"))) S G=1
..I C]"",$D(^ATXAX(Z,21,"B",C)) S G=1
..Q:'G
..Q:$D(^ATXAX(BUDTX,21,"B",J))
..S BUDD=BUDD+1,^ATXAX(BUDTX,21,BUDD,0)=J_U_J
S DA=BUDTX,DIK="^ATXAX(" D IX1^DIK
Q
;
INC ;UPDATE INCOME LEVELS
S X=8 F S X=$O(^BUDEIL("B",X)) Q:X'=+X D
.S Y=$O(^BUDEIL("B",X,0))
.S C=X-8
.S $P(^BUDEIL(Y,0),U,2)=(C*4180)+41320
.S $P(^BUDEIL(Y,0),U,3)=(C*5230)+51670
.S $P(^BUDEIL(Y,0),U,4)=(C*4810)+47530
Q
BUDEENV ;IHS/CMI/LAB - environmental check post init;
+1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
+2 ;
ENV ;
+1 ; The following line prevents the "Disable Options..." and "Move
+2 ; Routines..." questions from being asked during the install.
+3 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+4 FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
+5 IF $$VERSION^XPDUTL("BGP")'>"17"
DO MES^XPDUTL($$CJ^XLFSTR("Version 17.1 of CRS (BGP) is required. Not installed",80))
DO SORRY(2)
+6 IF $$VERSION^XPDUTL("BUD")'>10.9
DO MES^XPDUTL($$CJ^XLFSTR("Version 11.0 of UDS (BUD) is required. Not installed",80))
DO SORRY(2)
+7 QUIT
+8 ;
+9 ;
PRE ;
+1 ;ADD ALL OTHERS BACK IN
+2 ;edit package name
+3 SET DA=$ORDER(^DIC(9.4,"C","BUD",0))
+4 IF DA
SET DIE="^DIC(9.4,"
SET DR=".01///IHS/RPMS UNIFORM DATA SYS"
DO ^DIE
KILL DA,DIE
+5 FOR DA=1:1:50
SET DIK="^BUDECNTL("
DO ^DIK
+6 FOR DA=1:1:50
SET DIK="^BUDEIL("
DO ^DIK
+7 FOR DA=1:1:50
SET DIK="^BUDETFIV("
DO ^DIK
+8 FOR DA=1:1:50
SET DIK="^BUDETTA("
DO ^DIK
+9 FOR DA=1:1:50
SET DIK="^BUDELST2("
DO ^DIK
+10 FOR DA=1:1:999
SET DIK="^BUDETSC("
DO ^DIK
+11 FOR DA=1:1:999
SET DIK="^BUDETSSC("
DO ^DIK
+12 QUIT
POST ;
+1 ;move site parameters from 04 to 05 on first time install only
+2 IF '$ORDER(^BUDESITE(0))
Begin DoDot:1
+3 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDDSITE(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:2
+4 MERGE ^BUDESITE(BUDX)=^BUDDSITE(BUDX)
+5 SET DA=BUDX
SET DIK="^BUDESITE("
DO IX1^DIK
End DoDot:2
End DoDot:1
+6 ;create and populate drug taxonomy
+7 DO ^BUDE1
+8 DO ^BUDE2
+9 DO DRUG
+10 DO LAB
+11 DO SETICD
+12 QUIT
SETICD ;
+1 ;NOW DO TABLE 6B/7 LISTS
DX ;DX 11 NODE
+1 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDETSSC(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+2 SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDETSSC(BUDX,11,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:2
+3 FOR X=2,3
SET $PIECE(^BUDETSSC(BUDX,11,BUDY,0),U,X)=""
End DoDot:2
End DoDot:1
+4 KILL ^BUDETSSC("AD")
+5 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDETSSC(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+6 SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDETSSC(BUDX,11,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:2
+7 SET I=$PIECE(^BUDETSSC(BUDX,11,BUDY,0),U,1)
+8 SET I=$$ICDDX^ICDEX(I,DT)
+9 SET $PIECE(^BUDETSSC(BUDX,11,BUDY,0),U,2)=$PIECE(I,U,1)
+10 SET $PIECE(^BUDETSSC(BUDX,11,BUDY,0),U,3)=$PIECE(I,U,20)
End DoDot:2
End DoDot:1
+11 ;S DIK="^BUDETSSC(" D IXALL^DIK
+12 ;PROC
+13 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDETSSC(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+14 SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDETSSC(BUDX,12,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:2
+15 FOR X=2,3
SET $PIECE(^BUDETSSC(BUDX,12,BUDY,0),U,X)=""
End DoDot:2
End DoDot:1
+16 KILL ^BUDETSSC("AP")
+17 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDETSSC(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+18 SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDETSSC(BUDX,12,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:2
+19 SET I=$PIECE(^BUDETSSC(BUDX,12,BUDY,0),U,1)
+20 SET I=$$ICDOP^ICDEX(I,DT)
+21 SET $PIECE(^BUDETSSC(BUDX,12,BUDY,0),U,2)=$PIECE(I,U,1)
+22 SET $PIECE(^BUDETSSC(BUDX,12,BUDY,0),U,3)=$PIECE(I,U,15)
End DoDot:2
End DoDot:1
+23 SET DIK="^BUDETSSC("
DO IXALL^DIK
+24 QUIT
LAB ;EP
+1 SET BUDX="BGP HIV TEST TAX"
DO LAB1
+2 SET BUDX="BGP CD4 TAX"
DO LAB1
+3 SET BUDX="BGP HIV VIRAL LOAD TAX"
DO LAB1
+4 QUIT
LAB1 ;
+1 SET BUDDA=$ORDER(^ATXLAB("B",BUDX,0))
+2 ;taxonomy already exisits
IF BUDDA
QUIT
+3 WRITE !,"Creating ",BUDX," Taxonomy..."
+4 SET X=BUDX
SET DIC="^ATXLAB("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002228
DO ^DIC
KILL DIC,DA,DIADD,DLAYGO,I
+5 IF Y=-1
WRITE !!,"ERROR IN CREATING ",BUDX," TAX"
QUIT
+6 SET BUDTX=+Y
SET $PIECE(^ATXLAB(BUDTX,0),U,2)=BUDX
SET $PIECE(^(0),U,5)=DUZ
SET $PIECE(^(0),U,6)=DT
SET $PIECE(^(0),U,8)="B"
SET $PIECE(^(0),U,9)=60
+7 SET ^ATXLAB(BUDTX,21,0)="^9002228.02101PA^0^0"
+8 SET DA=BUDTX
SET DIK="^ATXAX("
DO IX1^DIK
+9 QUIT
+10 ;
INSTALLD(BUDSTAL) ;EP - Determine if patch BUDSTAL was installed, where
+1 ; BUDSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 ;
+3 NEW BUDY,DIC,X,Y
+4 SET X=$PIECE(BUDSTAL,"*",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(BUDSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
DO IMES
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(BUDSTAL,"*",3)
+12 DO ^DIC
+13 SET BUDY=Y
+14 DO IMES
+15 QUIT $SELECT(BUDY<1:0,1:1)
IMES ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BUDSTAL_""" 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
DRUG ;EP set up drug taxonomies
+1 SET ATXFLG=1
+2 SET BUDX="BUD DIABETES MEDS TAX"
SET BUDTAX=""
SET BUDNDCT="BUD DIABETES MEDS NDC"
DO DRUG1
+3 SET BUDX="BGP PQA CONTROLLER MEDS"
SET BUDTAX=""
SET BUDNDCT="BGP PQA CONTROLLER NDC"
DO DRUG1
+4 SET BUDX="BGP HEDIS ANTIDEPRESSANT MEDS"
SET BUDTAX=""
SET BUDNDCT="BGP HEDIS ANTIDEPRESSANT NDC"
DO DRUG1
+5 SET BUDX="BGP PQA SABA MEDS"
SET BUDTAX=""
SET BUDNDCT="BGP PQA SABA NDC"
DO DRUG1
+6 SET BUDX="BUD LIPID LOWERING MEDS"
SET BUDTAX=""
SET BUDNDCT="BGPMU LIPID LOWERING NDCS"
DO DRUG1
+7 SET BUDX="BUD ANTIPLATELET MEDS"
SET BUDTAX=""
SET BUDNDCT="BGPMU IVD ANTIPLATELET NDCS"
DO DRUG1
+8 SET BUDX="BGP HEDIS ANTIDEPRESSANT MEDS"
SET BUDTAX=""
SET BUDNDCT="BGP HEDIS ANTIDEPRESSANT NDC"
DO DRUG1
+9 SET BUDX="BGP PQA WARFARIN MEDS"
SET BUDTAX=""
SET BUDNDCT="BGP PQA WARFARIN NDC"
DO DRUG1
+10 SET BUDX="BGP PQA NON-WARF ANTICOAG MEDS"
SET BUDTAX=""
SET BUDNDCT="BGP PQA NON-WARF ANTICOAG NDC"
DO DRUG1
+11 KILL ATXFLG,BUDX,BUDDA,BUDTX,BUDNDCT,BUDTAX
+12 QUIT
DRUG1 ;
+1 WRITE !,"Creating ",BUDX," Taxonomy..."
+2 SET BUDTX=$ORDER(^ATXAX("B",BUDX,0))
+3 IF 'BUDTX
Begin DoDot:1
+4 SET X=BUDX
SET DIC="^ATXAX("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002226
DO ^DIC
KILL DIC,DA,DIADD,DLAYGO,I
+5 IF Y=-1
WRITE !!,"ERROR IN CREATING ",BUDX," TAX"
QUIT
+6 SET BUDTX=+Y
SET $PIECE(^ATXAX(BUDTX,0),U,2)=BUDX
SET $PIECE(^(0),U,8)=0
SET $PIECE(^(0),U,9)=DT
SET $PIECE(^(0),U,12)=173
SET $PIECE(^(0),U,13)=0
SET $PIECE(^(0),U,15)=50
SET ^ATXAX(BUDTX,21,0)="^9002226.02101A^0^0"
End DoDot:1
IF Y=-1
QUIT
+7 SET DA=BUDTX
SET DIK="^ATXAX("
DO IX1^DIK
+8 IF $GET(BUDTAX)]""
Begin DoDot:1
+9 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BUDTX,21,A))
IF A'=+A
QUIT
SET B=A
+10 SET BUDD=B
+11 SET ^ATXAX(BUDTX,21,0)="^9002226.02101A^"_B_U_B
+12 SET Z=$ORDER(^ATXAX("B",BUDTAX,0))
+13 SET J=0
FOR
SET J=$ORDER(^PSDRUG(J))
IF J'=+J
QUIT
SET C=$PIECE($GET(^PSDRUG(J,0)),U,2)
IF C]""
IF $DATA(^ATXAX(Z,21,"B",C))
Begin DoDot:2
+14 IF $DATA(^ATXAX(BUDTX,21,"B",J))
QUIT
+15 SET BUDD=BUDD+1
SET ^ATXAX(BUDTX,21,BUDD,0)=J_U_J
End DoDot:2
End DoDot:1
+16 IF $GET(BUDNDCT)]""
Begin DoDot:1
+17 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BUDTX,21,A))
IF A'=+A
QUIT
SET B=A
+18 SET BUDD=B
+19 SET ^ATXAX(BUDTX,21,0)="^9002226.02101A^"_B_U_B
+20 SET Z=$ORDER(^ATXAX("B",BUDNDCT,0))
+21 SET J=0
FOR
SET J=$ORDER(^PSDRUG(J))
IF J'=+J
QUIT
Begin DoDot:2
+22 SET G=0
+23 SET C=$PIECE($GET(^PSDRUG(J,2)),U,4)
+24 IF C]""
IF $DATA(^ATXAX(Z,21,"B",$$STRIP^XLFSTR(C,"-")))
SET G=1
+25 IF C]""
IF $DATA(^ATXAX(Z,21,"B",C))
SET G=1
+26 IF 'G
QUIT
+27 IF $DATA(^ATXAX(BUDTX,21,"B",J))
QUIT
+28 SET BUDD=BUDD+1
SET ^ATXAX(BUDTX,21,BUDD,0)=J_U_J
End DoDot:2
End DoDot:1
+29 SET DA=BUDTX
SET DIK="^ATXAX("
DO IX1^DIK
+30 QUIT
+31 ;
INC ;UPDATE INCOME LEVELS
+1 SET X=8
FOR
SET X=$ORDER(^BUDEIL("B",X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET Y=$ORDER(^BUDEIL("B",X,0))
+3 SET C=X-8
+4 SET $PIECE(^BUDEIL(Y,0),U,2)=(C*4180)+41320
+5 SET $PIECE(^BUDEIL(Y,0),U,3)=(C*5230)+51670
+6 SET $PIECE(^BUDEIL(Y,0),U,4)=(C*4810)+47530
End DoDot:1
+7 QUIT
