Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BUDEENV

BUDEENV.m

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