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

BUDHENV.m

Go to the documentation of this file. 
  1. BUDHENV ;IHS/CMI/LAB - environmental check post init;
  1.  ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
  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")'>"18" D MES^XPDUTL($$CJ^XLFSTR("Version 18.1 of CRS (BGP) is required.  Not installed",80)) D SORRY(2)
  1.  I $$VERSION^XPDUTL("BUD")'>11.9 D MES^XPDUTL($$CJ^XLFSTR("Version 12.0 of UDS (BUD) is required.  Not installed",80)) D SORRY(2)
  1.  I '$$INSTALLD("BUD*12.0*1") D SORRY(2)
  1.  Q
  1.  ;
  1.  ;
  1. PRE ;
  1.  ;DELETE ALL DATA FROM FILES FOR CLEAN ENTRY
  1.  ;edit package name
  1.  F DA=1:1:50 S DIK="^BUDHCNTL(" D ^DIK
  1.  F DA=1:1:50 S DIK="^BUDHIL(" D ^DIK
  1.  F DA=1:1:100 S DIK="^BUDHTFIV(" D ^DIK
  1.  F DA=1:1:100 S DIK="^BUDHTTA(" D ^DIK
  1.  F DA=1:1:100 S DIK="^BUDHLST2(" D ^DIK
  1.  F DA=1:1:999 S DIK="^BUDHTSC(" D ^DIK
  1.  F DA=1:1:999 S DIK="^BUDHTSSC(" D ^DIK
  1.  Q
  1. POST ;
  1.  ;move site parameters from 04 to 05 on first time install only
  1.  I '$O(^BUDHSITE(0)) D
  1.  .S BUDX=0 F  S BUDX=$O(^BUDESITE(BUDX)) Q:BUDX'=+BUDX   D
  1.  ..M ^BUDHSITE(BUDX)=^BUDESITE(BUDX)
  1.  ..S DA=BUDX,DIK="^BUDHSITE(" D IX1^DIK
  1.  D ^BUDH1
  1.  D ^BUDH2
  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(^BUDHTSSC(BUDX)) Q:BUDX'=+BUDX  D
  1.  .S BUDY=0 F  S BUDY=$O(^BUDHTSSC(BUDX,11,BUDY)) Q:BUDY'=+BUDY  D
  1.  ..F X=2,3 S $P(^BUDHTSSC(BUDX,11,BUDY,0),U,X)=""
  1.  K ^BUDHTSSC("AD")
  1.  S BUDX=0 F  S BUDX=$O(^BUDHTSSC(BUDX)) Q:BUDX'=+BUDX  D
  1.  .S BUDY=0 F  S BUDY=$O(^BUDHTSSC(BUDX,11,BUDY)) Q:BUDY'=+BUDY  D
  1.  ..S I=$P(^BUDHTSSC(BUDX,11,BUDY,0),U,1)
  1.  ..S I=$$ICDDX^ICDEX(I,DT)
  1.  ..S $P(^BUDHTSSC(BUDX,11,BUDY,0),U,2)=$P(I,U,1)
  1.  ..S $P(^BUDHTSSC(BUDX,11,BUDY,0),U,3)=$P(I,U,20)
  1.  ;S DIK="^BUDHTSSC(" D IXALL^DIK
  1.  ;PROC
  1.  S BUDX=0 F  S BUDX=$O(^BUDHTSSC(BUDX)) Q:BUDX'=+BUDX  D
  1.  .S BUDY=0 F  S BUDY=$O(^BUDHTSSC(BUDX,12,BUDY)) Q:BUDY'=+BUDY  D
  1.  ..F X=2,3 S $P(^BUDHTSSC(BUDX,12,BUDY,0),U,X)=""
  1.  K ^BUDHTSSC("AP")
  1.  S BUDX=0 F  S BUDX=$O(^BUDHTSSC(BUDX)) Q:BUDX'=+BUDX  D
  1.  .S BUDY=0 F  S BUDY=$O(^BUDHTSSC(BUDX,12,BUDY)) Q:BUDY'=+BUDY  D
  1.  ..S I=$P(^BUDHTSSC(BUDX,12,BUDY,0),U,1)
  1.  ..S I=$$ICDOP^ICDEX(I,DT)
  1.  ..S $P(^BUDHTSSC(BUDX,12,BUDY,0),U,2)=$P(I,U,1)
  1.  ..S $P(^BUDHTSSC(BUDX,12,BUDY,0),U,3)=$P(I,U,15)
  1.  S DIK="^BUDHTSSC(" 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 exists
  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(^BUDHIL("B",X)) Q:X'=+X  D
  1.  .S Y=$O(^BUDHIL("B",X,0))
  1.  .S C=X-8
  1.  .S $P(^BUDHIL(Y,0),U,2)=(C*4320)+42380
  1.  .S $P(^BUDHIL(Y,0),U,3)=(C*5400)+52980
  1.  .S $P(^BUDHIL(Y,0),U,4)=(C*4970)+48750
  1.  Q