BUDDENV ; IHS/CMI/LAB - environmental check 13 Jan 2014 7:22 AM 30 Nov 2016 10:58 AM ;
;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
;
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")'>"16.9" D MES^XPDUTL($$CJ^XLFSTR("Version 17 of CRS (BGP) is required. Not installed",80)) D SORRY(2)
I $$VERSION^XPDUTL("BUD")'>9.9 D MES^XPDUTL($$CJ^XLFSTR("Version 10.0 of UDS (BUD) is required. Not installed",80)) D SORRY(2)
Q
;
;
PRE ;
;ADD ALL OTHERS BACK IN
F DA=1:1:50 S DIK="^BUDDCNTL(" D ^DIK
F DA=1:1:50 S DIK="^BUDDIL(" D ^DIK
F DA=1:1:50 S DIK="^BUDDTFIV(" D ^DIK
F DA=1:1:50 S DIK="^BUDDTTA(" D ^DIK
F DA=1:1:50 S DIK="^BUDDLST2(" D ^DIK
F DA=1:1:999 S DIK="^BUDDTSC(" D ^DIK
F DA=1:1:999 S DIK="^BUDDTSSC(" D ^DIK
Q
POST ;
;move site parameters from 04 to 05 on first time install only
I '$O(^BUDDSITE(0)) D
.S BUDX=0 F S BUDX=$O(^BUDCSITE(BUDX)) Q:BUDX'=+BUDX D
..M ^BUDDSITE(BUDX)=^BUDCSITE(BUDX)
..S DA=BUDX,DIK="^BUDDSITE(" D IX1^DIK
;create and populate drug taxonomy
D ^BUDD1
D DRUG
D LAB
D SETICD
Q
SETICD ;
;FIRST WIPE OUT WHAT WAS SENT WITH KIDS
S BUDX=0 F S BUDX=$O(^BUDDTSC(BUDX)) Q:BUDX'=+BUDX D
.S BUDY=0 F S BUDY=$O(^BUDDTSC(BUDX,7,BUDY)) Q:BUDY'=+BUDY D
..F X=2,3 S $P(^BUDDTSC(BUDX,7,BUDY,0),U,X)=""
K ^BUDDTSC("AC")
S BUDX=0 F S BUDX=$O(^BUDDTSC(BUDX)) Q:BUDX'=+BUDX D
.S BUDY=0 F S BUDY=$O(^BUDDTSC(BUDX,7,BUDY)) Q:BUDY'=+BUDY D
..S I=$P(^BUDDTSC(BUDX,7,BUDY,0),U,1)
..S I=$$ICDDX^ICDEX(I,DT)
..S $P(^BUDDTSC(BUDX,7,BUDY,0),U,2)=$P(I,U,1)_U_$P(I,U,20)
S DIK="^BUDDTSC(" D IXALL^DIK
;NOW DO TABLE 6B/7 LISTS
DX ;DX 11 NODE
S BUDX=0 F S BUDX=$O(^BUDDTSSC(BUDX)) Q:BUDX'=+BUDX D
.S BUDY=0 F S BUDY=$O(^BUDDTSSC(BUDX,11,BUDY)) Q:BUDY'=+BUDY D
..F X=2,3 S $P(^BUDDTSSC(BUDX,11,BUDY,0),U,X)=""
K ^BUDDTSSC("AD")
S BUDX=0 F S BUDX=$O(^BUDDTSSC(BUDX)) Q:BUDX'=+BUDX D
.S BUDY=0 F S BUDY=$O(^BUDDTSSC(BUDX,11,BUDY)) Q:BUDY'=+BUDY D
..S I=$P(^BUDDTSSC(BUDX,11,BUDY,0),U,1)
..S I=$$ICDDX^ICDEX(I,DT)
..S $P(^BUDDTSSC(BUDX,11,BUDY,0),U,2)=$P(I,U,1)
..S $P(^BUDDTSSC(BUDX,11,BUDY,0),U,3)=$P(I,U,20)
;S DIK="^BUDDTSSC(" D IXALL^DIK
;PROC
S BUDX=0 F S BUDX=$O(^BUDDTSSC(BUDX)) Q:BUDX'=+BUDX D
.S BUDY=0 F S BUDY=$O(^BUDDTSSC(BUDX,12,BUDY)) Q:BUDY'=+BUDY D
..F X=2,3 S $P(^BUDDTSSC(BUDX,12,BUDY,0),U,X)=""
K ^BUDDTSSC("AP")
S BUDX=0 F S BUDX=$O(^BUDDTSSC(BUDX)) Q:BUDX'=+BUDX D
.S BUDY=0 F S BUDY=$O(^BUDDTSSC(BUDX,12,BUDY)) Q:BUDY'=+BUDY D
..S I=$P(^BUDDTSSC(BUDX,12,BUDY,0),U,1)
..S I=$$ICDOP^ICDEX(I,DT)
..S $P(^BUDDTSSC(BUDX,12,BUDY,0),U,2)=$P(I,U,1)
..S $P(^BUDDTSSC(BUDX,12,BUDY,0),U,3)=$P(I,U,15)
S DIK="^BUDDTSSC(" 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
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(^BUDDIL("B",X)) Q:X'=+X D
.S Y=$O(^BUDDIL("B",X,0))
.S C=X-8
.S $P(^BUDDIL(Y,0),U,2)=(C*4160)+40890
.S $P(^BUDDIL(Y,0),U,3)=(C*5200)+51120
.S $P(^BUDDIL(Y,0),U,4)=(C*4780)+47010
Q
BUDDENV ; IHS/CMI/LAB - environmental check 13 Jan 2014 7:22 AM 30 Nov 2016 10:58 AM ;
+1 ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
+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")'>"16.9"
DO MES^XPDUTL($$CJ^XLFSTR("Version 17 of CRS (BGP) is required. Not installed",80))
DO SORRY(2)
+6 IF $$VERSION^XPDUTL("BUD")'>9.9
DO MES^XPDUTL($$CJ^XLFSTR("Version 10.0 of UDS (BUD) is required. Not installed",80))
DO SORRY(2)
+7 QUIT
+8 ;
+9 ;
PRE ;
+1 ;ADD ALL OTHERS BACK IN
+2 FOR DA=1:1:50
SET DIK="^BUDDCNTL("
DO ^DIK
+3 FOR DA=1:1:50
SET DIK="^BUDDIL("
DO ^DIK
+4 FOR DA=1:1:50
SET DIK="^BUDDTFIV("
DO ^DIK
+5 FOR DA=1:1:50
SET DIK="^BUDDTTA("
DO ^DIK
+6 FOR DA=1:1:50
SET DIK="^BUDDLST2("
DO ^DIK
+7 FOR DA=1:1:999
SET DIK="^BUDDTSC("
DO ^DIK
+8 FOR DA=1:1:999
SET DIK="^BUDDTSSC("
DO ^DIK
+9 QUIT
POST ;
+1 ;move site parameters from 04 to 05 on first time install only
+2 IF '$ORDER(^BUDDSITE(0))
Begin DoDot:1
+3 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDCSITE(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:2
+4 MERGE ^BUDDSITE(BUDX)=^BUDCSITE(BUDX)
+5 SET DA=BUDX
SET DIK="^BUDDSITE("
DO IX1^DIK
End DoDot:2
End DoDot:1
+6 ;create and populate drug taxonomy
+7 DO ^BUDD1
+8 DO DRUG
+9 DO LAB
+10 DO SETICD
+11 QUIT
SETICD ;
+1 ;FIRST WIPE OUT WHAT WAS SENT WITH KIDS
+2 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDDTSC(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+3 SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDDTSC(BUDX,7,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:2
+4 FOR X=2,3
SET $PIECE(^BUDDTSC(BUDX,7,BUDY,0),U,X)=""
End DoDot:2
End DoDot:1
+5 KILL ^BUDDTSC("AC")
+6 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDDTSC(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+7 SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDDTSC(BUDX,7,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:2
+8 SET I=$PIECE(^BUDDTSC(BUDX,7,BUDY,0),U,1)
+9 SET I=$$ICDDX^ICDEX(I,DT)
+10 SET $PIECE(^BUDDTSC(BUDX,7,BUDY,0),U,2)=$PIECE(I,U,1)_U_$PIECE(I,U,20)
End DoDot:2
End DoDot:1
+11 SET DIK="^BUDDTSC("
DO IXALL^DIK
+12 ;NOW DO TABLE 6B/7 LISTS
DX ;DX 11 NODE
+1 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDDTSSC(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+2 SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDDTSSC(BUDX,11,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:2
+3 FOR X=2,3
SET $PIECE(^BUDDTSSC(BUDX,11,BUDY,0),U,X)=""
End DoDot:2
End DoDot:1
+4 KILL ^BUDDTSSC("AD")
+5 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDDTSSC(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+6 SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDDTSSC(BUDX,11,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:2
+7 SET I=$PIECE(^BUDDTSSC(BUDX,11,BUDY,0),U,1)
+8 SET I=$$ICDDX^ICDEX(I,DT)
+9 SET $PIECE(^BUDDTSSC(BUDX,11,BUDY,0),U,2)=$PIECE(I,U,1)
+10 SET $PIECE(^BUDDTSSC(BUDX,11,BUDY,0),U,3)=$PIECE(I,U,20)
End DoDot:2
End DoDot:1
+11 ;S DIK="^BUDDTSSC(" D IXALL^DIK
+12 ;PROC
+13 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDDTSSC(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+14 SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDDTSSC(BUDX,12,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:2
+15 FOR X=2,3
SET $PIECE(^BUDDTSSC(BUDX,12,BUDY,0),U,X)=""
End DoDot:2
End DoDot:1
+16 KILL ^BUDDTSSC("AP")
+17 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDDTSSC(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+18 SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDDTSSC(BUDX,12,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:2
+19 SET I=$PIECE(^BUDDTSSC(BUDX,12,BUDY,0),U,1)
+20 SET I=$$ICDOP^ICDEX(I,DT)
+21 SET $PIECE(^BUDDTSSC(BUDX,12,BUDY,0),U,2)=$PIECE(I,U,1)
+22 SET $PIECE(^BUDDTSSC(BUDX,12,BUDY,0),U,3)=$PIECE(I,U,15)
End DoDot:2
End DoDot:1
+23 SET DIK="^BUDDTSSC("
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 KILL ATXFLG,BUDX,BUDDA,BUDTX,BUDNDCT,BUDTAX
+9 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(^BUDDIL("B",X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET Y=$ORDER(^BUDDIL("B",X,0))
+3 SET C=X-8
+4 SET $PIECE(^BUDDIL(Y,0),U,2)=(C*4160)+40890
+5 SET $PIECE(^BUDDIL(Y,0),U,3)=(C*5200)+51120
+6 SET $PIECE(^BUDDIL(Y,0),U,4)=(C*4780)+47010
End DoDot:1
+7 QUIT
