BJPC2ENV ; IHS/CMI/LAB - PCC Suite v1.0 patch 1 environment check ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;
; 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 '$$INSTALLD("BJPC*1.0*1") D SORRY(2)
I '$$INSTALLD("AUT*98.1*22") D SORRY(2)
I $$VERSION^XPDUTL("BQI")="1.1",'$$INSTALLD("BQI*1.1*2") D SORRY(2)
;
Q
;
PRE ;
D PRE^BJPC2ENP
Q
POST ;
S BJPCX=0 F S BJPCX=$O(^AUPNVELD(BJPCX)) Q:BJPCX'=+BJPCX D
.I $P(^AUPNVELD(BJPCX,0),U,1)["""" D
..S DA=BJPCX,DIE="^AUPNVELD(",DR=".01///IHS-1-865" D ^DIE K DA,DIE,DR
D MES^XPDUTL("Updating QMAN")
D POST^AMQQPOST
D ^BJPC2X,^BJPC2T,^BJPC2U,^BJPC1T
D MES^XPDUTL("Updating Lab Taxonomies")
D LABTAX ;install lab taxonomies if they don't exist
D MES^XPDUTL("Updating Medication Taxonomies")
D MEDTAX
D MES^XPDUTL("Updating Taxonomies for DM system")
D DMADA
D ^BJPC2EV1
D MES^XPDUTL("Updating CAR taxonomies") D POST^APCLCART
D MES^XPDUTL("Updating all other taxonomies")
D UPDTAXR
D MOVEFH^BJPC2EV3
;d/e mnemonic
S DA=$O(^APCDTKW("B","ASEV",0)) I DA S DIK="^APCDTKW(" D ^DIK
S DA=$O(^APCDTKW("B","HSEV",0)) I DA S DIK="^APCDTKW(" D ^DIK K DA,DIK
K DA,DIK
I '$D(^APCDTKW("B","ACON")) D
.S X="ACON",DIC(0)="L",DIC="^APCDTKW(",DIC("DR")=".03///9000010;.04///[APCD ACON];.06///Asthma Control;.07///0;.08///1;.09///9000010.41"
.K DD,D0,DO
.D FILE^DICN
.I Y=-1 D MES^XPDUTL("Adding ACON mnemonic failed.") H 4
;d/e mnemonic
I '$D(^APCDTKW("B","AMP")) D
.S X="AMP",DIC(0)="L",DIC="^APCDTKW(",DIC("DR")=".03///9000010;.04///[APCD AMP];.06///Asthma Management Plan;.07///0;.08///1;.09///9000010.41"
.K DD,D0,DO
.D FILE^DICN
.I Y=-1 D MES^XPDUTL("Adding AMP mnemonic failed.") H 4
S DA=$O(^APCDTKW("B","AMP",0))
I DA S DIE="^APCDTKW(",DR=".06///Asthma Management Plan" D ^DIE K DIE,DA,DR
OPTIONS ;
S X=$$ADD^XPDMENU("APCLMENU","AKMOFMAN","FM")
I 'X W "Attempt to add fileman general report option failed.." H 3
S X=$$ADD^XPDMENU("APCLMENU","ATSMENU","STS")
I 'X W "Attempt to add SEARCH TEMPLATE SYSTEM report option failed.." H 3
S X=$$ADD^XPDMENU("APCD LTM MENU","AVA PROVIDER ADD/EDIT","PRV")
I 'X W "Attempt to add PROV ADD/EDIT option failed.." H 3
S X=$$ADD^XPDMENU("APCD LTM MENU","AVA INACTIVATE/REACTIVATE","INA")
I 'X W "Attempt to add PROV INAC/REAC option failed.." H 3
HIVPROV ;convert HIV providers
D MES^XPDUTL("Moving HIV providers to BDP package")
S BJPCX=0 F S BJPCX=$O(^BKM(90451,BJPCX)) Q:BJPCX'=+BJPCX D
.S BJPCY=0 F S BJPCY=$O(^BKM(90451,BJPCX,1,BJPCY)) Q:BJPCY'=+BJPCY D
..S DFN=$P(^BKM(90451,BJPCX,0),U)
..S BJPCP=$P($G(^BKM(90451,BJPCX,1,BJPCY,3)),U) I BJPCP D
...D AEDAP^BDPAPI(DFN,BJPCP,"HIV PROVIDER",.BJPCR)
...I 'BJPCR D MES^XPDUTL("Error copying HIV Provider for "_DFN)
..S BJPCP=$P($G(^BKM(90451,BJPCX,1,BJPCY,3)),U,2) I BJPCP D
...D AEDAP^BDPAPI(DFN,BJPCP,"HIV CASE MANAGER",.BJPCR)
...I 'BJPCR D MES^XPDUTL("Error copying HIV Case manager for "_DFN)
EXAMINAC ;
;inactivate exams 23, 08, 05
D MES^XPDUTL("Inactivating Exam Codes")
S DA=$O(^AUTTEXAM("C","23",0)) I DA S DIE="^AUTTEXAM(",DR=".04////1" D ^DIE K DA,DIE,DR
S DA=$O(^AUTTEXAM("C","08",0)) I DA S DIE="^AUTTEXAM(",DR=".04////1" D ^DIE K DA,DIE,DR
S DA=$O(^AUTTEXAM("C","05",0)) I DA S DIE="^AUTTEXAM(",DR=".04////1" D ^DIE K DA,DIE,DR
HMRSTAT ;
;PUT STATUS BACK IN
S APCHX=0 F S APCHX=$O(^APCHTMP("HMR STATUS",APCHX)) Q:APCHX'=+APCHX D
.S X=$P(^APCHTMP("HMR STATUS",APCHX),U),APCHS=$P(^APCHTMP("HMR STATUS",APCHX),U,2) ;,DIC="^APCHSURV(",DIC(0)="M" D ^DIC
.;I Y=-1 W !!,"could not update status on ",X," hmr" Q
.Q:'$D(^APCHSURV(APCHX,0))
.I $P(^APCHSURV(APCHX,0),U,3)'="D" S $P(^APCHSURV(APCHX,0),U,3)=APCHS
K ^APCHTMP("HMR STATUS")
ASMSMP ;
D MES^XPDUTL($$CJ^XLFSTR("Copying Asthma Management Plan to V Patient Education.",IOM))
S X=0,BJPCIEN="" F S X=$O(^AUTTEDT("C","ASM-SMP",X)) Q:X'=+X!(BJPCIEN) D
.Q:'$D(^AUTTEDT(X,0))
.Q:$P(^AUTTEDT(X,0),U,3)
.S BJPCIEN=X
I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("ASM-SMP education topic missing from file, cannot move data.",IOM)) G HF
S BJPCX=0 F S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX D
.Q:$P($G(^AUPNVAST(BJPCX,0)),U,12)="" ;no asthma management plan to copy
.Q:$P($G(^AUPNVAST(BJPCX,0)),U,12)'=1
.Q:$$HASASAMP($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
.K APCDALVR
.S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.16 (ADD)]"
.S APCDALVR("APCDTTOP")="`"_BJPCIEN
.S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Patient ed ASM-SMP failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
.K APCDALVR
HF ;
D MES^XPDUTL("Updating HEALTH FACTOR table")
D ^BJPC2EVH
D ^BJPC2EV2 ;update problem list classification from latest v asthma stage
RHC ;
D CONVRH^AUPNREP
;REINDEX ALM xref
NEW DIK
S DIK="^AUPNVDEN(",DIK(1)="1209^AXK" D ENALL^DIK K DIK
;
;D WRITEMSG
Q
WRITEMSG ;
S X=$O(^APCLPDES("B","BJPCV2",0))
Q:'X
S Y=0 F S Y=$O(^APCLPDES(X,11,Y)) Q:Y'=+Y S ^TMP($J,"BJPCBUL",Y)=^APCLPDES(X,11,Y,0)
Q
;
GETRECIP ;
;
S CTR=0
F BJPCKEY="APCLZMENU","APCDZMENU","APCHZMENU","BDPZMENU","AMQQZMENU"
F S CTR=$O(^XUSEC(BJPCKEY,CTR)) Q:'CTR S Y=CTR S XMY(Y)=""
Q
INSTALLD(BJPCSTAL) ;EP - Determine if patch BJPCSTAL was installed, where
; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
;
NEW BJPCY,DIC,X,Y
S X=$P(BJPCSTAL,"*",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(BJPCSTAL,"*",2)
D ^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(BJPCSTAL,"*",3)
D ^DIC
S BJPCY=Y
D IMES
Q $S(BJPCY<1:0,1:1)
IMES ;
D MES^XPDUTL($$CJ^XLFSTR("Patch """_BJPCSTAL_""" 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
;
LABTAX ;EP
S BJPCX="APCH FECAL OCCULT BLOOD",BJPCPG="APCH",BJPCAP=0 D LAB1
S BJPCX="APCH HCT/HGB TESTS",BJPCPG="APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT 2 HR GTT TAX",BJPCPG="BDM,APCL,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT 75GM 2HR GLUCOSE",BJPCPG="BDM,APCL,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT A/C RATIO TAX",BJPCPG="BDM,APCL,BGP,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT AST TAX",BJPCPG="BDM,APCL,BGP,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT ALT TAX",BJPCPG="BDM,APCL,BGP,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT CHOLESTEROL TAX",BJPCPG="BDM,APCL,BGP,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT CREATININE TAX",BJPCPG="BDM,APCL,BGP,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT FASTING GLUCOSE TESTS",BJPCPG="BDM,APCL,BGP,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT GLUCOSE TESTS TAX",BJPCPG="BDM,APCL,BGP,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT HDL TAX",BJPCPG="BDM,APCL,BGP,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT HGB A1C TAX",BJPCPG="BDM,APCL,BGP,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT LDL CHOLESTEROL TAX",BJPCPG="BDM,APCL,BGP,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT MICROALBUMINURIA TAX",BJPCPG="BDM,APCL,BGP,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT P/C RATIO TAX",BJPCPG="BDM,APCL,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT TRIGLYCERIDE TAX",BJPCPG="BDM,APCL,BGP,APCH",BJPCAP=0 D LAB1
S BJPCX="DM AUDIT URINALYSIS TAX",BJPCPG="BDM,APCL,BGP,APCH",BJPCAP=1 D LAB1
S BJPCX="DM AUDIT URINE PROTEIN TAX",BJPCPG="BDM,APCL,BGP,APCH",BJPCAP=0 D LAB1
Q
;
LAB1 ;
S BJPCDA=$O(^ATXLAB("B",BJPCX,0))
I BJPCDA G UP41 ;taxonomy already exists
W !,"Creating ",BJPCX," Taxonomy..."
S X=BJPCX,DIC="^ATXLAB(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I
I Y=-1 W !!,"ERROR IN CREATING ",BJPCX," TAX" Q
S BJPCDA=+Y,$P(^ATXLAB(BJPCDA,0),U,2)=BJPCX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="B",$P(^(0),U,9)=60,$P(^(0),U,22)=0,$P(^(0),U,4)="n",$P(^(0),U,11)=BJPCAP
S ^ATXLAB(BJPCDA,21,0)="^9002228.02101PA^0^0"
S DA=BJPCDA,DIK="^ATXAX(" D IX1^DIK
UP41 ;
F BJPCI=1:1 S BJPCPI=$P(BJPCPG,",",BJPCI) Q:BJPCPI="" D
.S BJPCPI=$O(^DIC(9.4,"C","BJPC",0))
.Q:BJPCPI="" ;NO PACKAGE
.Q:$D(^ATXLAB(BJPCDA,41,"B",BJPCPI))
.S X="`"_BJPCPI,DIC="^ATXLAB("_BJPCDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002228,4101,0),U,2),DA(1)=BJPCDA
.D ^DIC
.I Y=-1 W !,"updating package multiple for ",BJPCPI," entry ",$P(^ATXAX(BJPCDA,0),U)," failed"
.K DIC,DA,Y,X
Q
;
DMADA ;
S ATXFLG=1
W !,"Updating APCH ADA Codes Taxonomy..."
S BJPCTX=0 S BJPCTX=$O(^ATXAX("B","APCH DM ADA EXAMS",BJPCTX))
I BJPCTX G TX1
S X="APCH DM ADA EXAMS",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I I Y=-1 W !!,"ERROR IN CREATING APCH DM ADA EXAMS TAXONOMY" Q
S BJPCTX=+Y,$P(^ATXAX(BJPCTX,0),U,2)="ADA CODES FOR DM EXAM",$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(BJPCTX,21,0)="^9002226.02101A^0^0"
TX1 S BJPCTEXT="ADA" F BJPCX=1:1:5 S X=$P($T(@BJPCTEXT+BJPCX),";;",2),DIC="^AUTTADA(",DIC(0)="M" D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0 I $P(Y,U)>0 D
.S Y=+Y Q:$D(^ATXAX(BJPCTX,21,"B",Y)) ;this code is already there.
.S BJPCL=0 S BJPCY=0 F S BJPCY=$O(^ATXAX(BJPCTX,21,BJPCY)) Q:BJPCY'=+BJPCY S BJPCL=BJPCY
.S BJPCL=BJPCL+1,^ATXAX(BJPCTX,21,BJPCL,0)=Y,$P(^ATXAX(BJPCTX,21,BJPCL,0),U,2)=Y,$P(^ATXAX(BJPCTX,21,0),U,3)=BJPCL,$P(^(0),U,4)=BJPCL,^ATXAX(BJPCTX,21,"AA",Y,Y)="",^ATXAX(BJPCTX,21,"B",Y,BJPCL)=""
.Q
S DA=BJPCTX,DIK="^ATXAX(" D IX1^DIK
K BJPCTX,BJPCDA,BJPCTEXT,ATXFLG
Q
;
MEDTAX ;EP set up drug taxonomies
S ATXFLG=1
S BJPCX="DM AUDIT ASPIRIN DRUGS",BJPCPG="BDM,APCH,APCL" D DRUG1
S BJPCX="DM AUDIT ACARBOSE DRUGS",BJPCPG="BDM,APCH,APCL" D DRUG1
S BJPCX="DM AUDIT ACE INHIBITORS",BJPCPG="BDM,APCH,APCL" D DRUG1
S BJPCX="DM AUDIT ANTI-PLATELET DRUGS",BJPCPG="BDM,APCH,APCL" D DRUG1
S BJPCX="DM AUDIT DPP4 INHIBITOR DRUGS",BJPCPG="BDM,APCH,APCL" D DRUG1
S BJPCX="DM AUDIT GLITAZONE DRUGS",BJPCPG="BDM,APCH,APCL" D DRUG1
S BJPCX="DM AUDIT INCRETIN MIMETIC",BJPCPG="BDM,APCH,APCL" D DRUG1
S BJPCX="DM AUDIT INSULIN DRUGS",BJPCPG="BDM,APCH,APCL" D DRUG1
S BJPCX="DM AUDIT LIPID LOWERING DRUGS",BJPCPG="BDM,APCH,APCL" D DRUG1
S BJPCX="DM AUDIT METFORMIN DRUGS",BJPCPG="BDM,APCH,APCL" D DRUG1
S BJPCX="DM AUDIT ORAL HYPOGLYCEMICS",BJPCPG="BDM,APCH,APCL" D DRUG1
S BJPCX="DM AUDIT SELF MONITOR DRUGS",BJPCPG="BDM,APCH,APCL" D DRUG1
S BJPCX="DM AUDIT STATIN DRUGS",BJPCPG="BDM,APCH,APCL" D DRUG1
S BJPCX="DM AUDIT SULFONYLUREA DRUGS",BJPCPG="BDM,APCH,APCL" D DRUG1
S BJPCX="BAT ASTHMA SHRT ACT RELV MEDS",BJPCNDCT="BAT ASTHMA SHRT ACT RELV NDC",BJPCTAX="",BJPCPG="APCH;BJPC" D DRUG1
S BJPCX="BAT ASTHMA SHRT ACT INHLR MEDS",BJPCNDCT="BAT ASTHMA SHRT ACT INHLR NDC",BJPCTAX="",BJPCPG="APCH;BJPC" D DRUG1
S BJPCX="BAT ASTHMA LEUKOTRIENE MEDS",BJPCNDCT="BAT ASTHMA LEUKOTRIENE NDC",BJPCTAX="",BJPCPG="APCH;BJPC" D DRUG1
S BJPCX="BAT ASTHMA CONTROLLER MEDS",BJPCNDCT="BAT ASTHMA CONTROLLER NDC",BJPCTAX="",BJPCPG="APCH;BJPC" D DRUG1
S BJPCX="BAT ASTHMA INHALED STEROIDS",BJPCNDCT="BAT ASTHMA INHLD STEROIDS NDC",BJPCTAX="",BJPCPG="APCH;BJPC" D DRUG1
S BJPCX="BGP RA GLUCOCORTICOIDS MEDS",BJPCTAX="BGP RA GLUCOCORTICOIDS CLASS",BJPCNDCT="",BJPCPG="APCH;BJPC" D DRUG1
Q
;
DRUG1 ;
S BJPCTX=$O(^ATXAX("B",BJPCX,0))
I 'BJPCTX D Q:Y=-1
.D MES^XPDUTL("Creating "_BJPCX_" taxonomy")
.S X=BJPCX,DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I
.I Y=-1 W !!,"ERROR IN CREATING ",BJPCX," TAX" Q
.S BJPCTX=+Y,$P(^ATXAX(BJPCTX,0),U,2)=BJPCX,$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,$P(^(0),U,22)=0,$P(^(0),U,4)="n",^ATXAX(BJPCTX,21,0)="^9002226.02101A^0^0"
S DA=BJPCTX,DIK="^ATXAX(" D IX1^DIK
D MES^XPDUTL("Updating "_BJPCX_" taxonomy")
I $G(BJPCTAX)]"" D
.S A=0,B="" F S A=$O(^ATXAX(BJPCTX,21,A)) Q:A'=+A S B=A
.S BJPCC=B
.S ^ATXAX(BJPCTX,21,0)="^9002226.02101A^"_B_U_B
.S Z=$O(^ATXAX("B",BJPCTAX,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(BJPCTX,21,"B",J))
..S BJPCC=BJPCC+1,^ATXAX(BJPCTX,21,BJPCC,0)=J_U_J
I $G(BJPCNDCT)]"" D
.S A=0,B="" F S A=$O(^ATXAX(BJPCTX,21,A)) Q:A'=+A S B=A
.S BJPCC=B
.S ^ATXAX(BJPCTX,21,0)="^9002226.02101A^"_B_U_B
.S Z=$O(^ATXAX("B",BJPCNDCT,0))
.S J=0 F S J=$O(^PSDRUG(J)) Q:J'=+J S C=$P($G(^PSDRUG(J,2)),U,4) I C]"",$D(^ATXAX(Z,21,"B",C)) D
..Q:$D(^ATXAX(BJPCTX,21,"B",J))
..S BJPCC=BJPCC+1,^ATXAX(BJPCTX,21,BJPCC,0)=J_U_J
S DA=BJPCTX,DIK="^ATXAX(" D IX1^DIK
Q
;
UP41M ;
F BJPCI=1:1 S BJPCPI=$P(BJPCPG,",",BJPCI) Q:BJPCPI="" D
.K DIC,DA,DR
.S BJPCPI=$O(^DIC(9.4,"C","BJPC",0))
.Q:BJPCPI="" ;NO PACKAGE
.Q:$D(^ATXAX(BJPCTX,41,"B",BJPCPI))
.S X="`"_BJPCPI,DIC="^ATXAX("_BJPCTX_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002226,4101,0),U,2),DA(1)=BJPCTX
.D ^DIC
.I Y=-1 W !,"updating package multiple for ",BJPCPI," entry ",$P(^ATXAX(BJPCTX,0),U)," failed"
.K DIC,DA,Y,X
.Q
Q
;
UPDTAXR ;
;update read only field and nodelete field for all taxonomies
S BJPCX=0 F S BJPCX=$O(^APCCTXC(BJPCX)) Q:BJPCX'=+BJPCX D
.S BJPCR=$P(^APCCTXC(BJPCX,0),U,2),BJPCND=$P(^APCCTXC(BJPCX,0),U,3),BJPCN=$P(^APCCTXC(BJPCX,0),U)
.S DA=$O(^ATXAX("B",BJPCN,0)) I DA S DIE="^ATXAX(",DR=".04///"_BJPCND_";.22///"_BJPCR D ^DIE K DA,DIE,DR
.Q
Q
HASASAMP(V,I) ;is there a v patient ed of ASM-SMP?
NEW X,Y,Z
S (X,Z)=0 F S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X D
.I $P($G(^AUPNVPED(X,0)),U)=I S Z=1
.Q
Q Z
;
ADA ;
;;0120
;;0150
;;0114
;;9320
;;9321
;;
BJPC2ENV ; IHS/CMI/LAB - PCC Suite v1.0 patch 1 environment check ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;
+4 ; The following line prevents the "Disable Options..." and "Move
+5 ; Routines..." questions from being asked during the install.
+6 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+7 FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
+8 IF '$$INSTALLD("BJPC*1.0*1")
DO SORRY(2)
+9 IF '$$INSTALLD("AUT*98.1*22")
DO SORRY(2)
+10 IF $$VERSION^XPDUTL("BQI")="1.1"
IF '$$INSTALLD("BQI*1.1*2")
DO SORRY(2)
+11 ;
+12 QUIT
+13 ;
PRE ;
+1 DO PRE^BJPC2ENP
+2 QUIT
POST ;
+1 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNVELD(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+2 IF $PIECE(^AUPNVELD(BJPCX,0),U,1)[""""
Begin DoDot:2
+3 SET DA=BJPCX
SET DIE="^AUPNVELD("
SET DR=".01///IHS-1-865"
DO ^DIE
KILL DA,DIE,DR
End DoDot:2
End DoDot:1
+4 DO MES^XPDUTL("Updating QMAN")
+5 DO POST^AMQQPOST
+6 DO ^BJPC2X
DO ^BJPC2T
DO ^BJPC2U
DO ^BJPC1T
+7 DO MES^XPDUTL("Updating Lab Taxonomies")
+8 ;install lab taxonomies if they don't exist
DO LABTAX
+9 DO MES^XPDUTL("Updating Medication Taxonomies")
+10 DO MEDTAX
+11 DO MES^XPDUTL("Updating Taxonomies for DM system")
+12 DO DMADA
+13 DO ^BJPC2EV1
+14 DO MES^XPDUTL("Updating CAR taxonomies")
DO POST^APCLCART
+15 DO MES^XPDUTL("Updating all other taxonomies")
+16 DO UPDTAXR
+17 DO MOVEFH^BJPC2EV3
+18 ;d/e mnemonic
+19 SET DA=$ORDER(^APCDTKW("B","ASEV",0))
IF DA
SET DIK="^APCDTKW("
DO ^DIK
+20 SET DA=$ORDER(^APCDTKW("B","HSEV",0))
IF DA
SET DIK="^APCDTKW("
DO ^DIK
KILL DA,DIK
+21 KILL DA,DIK
+22 IF '$DATA(^APCDTKW("B","ACON"))
Begin DoDot:1
+23 SET X="ACON"
SET DIC(0)="L"
SET DIC="^APCDTKW("
SET DIC("DR")=".03///9000010;.04///[APCD ACON];.06///Asthma Control;.07///0;.08///1;.09///9000010.41"
+24 KILL DD,D0,DO
+25 DO FILE^DICN
+26 IF Y=-1
DO MES^XPDUTL("Adding ACON mnemonic failed.")
HANG 4
End DoDot:1
+27 ;d/e mnemonic
+28 IF '$DATA(^APCDTKW("B","AMP"))
Begin DoDot:1
+29 SET X="AMP"
SET DIC(0)="L"
SET DIC="^APCDTKW("
SET DIC("DR")=".03///9000010;.04///[APCD AMP];.06///Asthma Management Plan;.07///0;.08///1;.09///9000010.41"
+30 KILL DD,D0,DO
+31 DO FILE^DICN
+32 IF Y=-1
DO MES^XPDUTL("Adding AMP mnemonic failed.")
HANG 4
End DoDot:1
+33 SET DA=$ORDER(^APCDTKW("B","AMP",0))
+34 IF DA
SET DIE="^APCDTKW("
SET DR=".06///Asthma Management Plan"
DO ^DIE
KILL DIE,DA,DR
OPTIONS ;
+1 SET X=$$ADD^XPDMENU("APCLMENU","AKMOFMAN","FM")
+2 IF 'X
WRITE "Attempt to add fileman general report option failed.."
HANG 3
+3 SET X=$$ADD^XPDMENU("APCLMENU","ATSMENU","STS")
+4 IF 'X
WRITE "Attempt to add SEARCH TEMPLATE SYSTEM report option failed.."
HANG 3
+5 SET X=$$ADD^XPDMENU("APCD LTM MENU","AVA PROVIDER ADD/EDIT","PRV")
+6 IF 'X
WRITE "Attempt to add PROV ADD/EDIT option failed.."
HANG 3
+7 SET X=$$ADD^XPDMENU("APCD LTM MENU","AVA INACTIVATE/REACTIVATE","INA")
+8 IF 'X
WRITE "Attempt to add PROV INAC/REAC option failed.."
HANG 3
HIVPROV ;convert HIV providers
+1 DO MES^XPDUTL("Moving HIV providers to BDP package")
+2 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^BKM(90451,BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+3 SET BJPCY=0
FOR
SET BJPCY=$ORDER(^BKM(90451,BJPCX,1,BJPCY))
IF BJPCY'=+BJPCY
QUIT
Begin DoDot:2
+4 SET DFN=$PIECE(^BKM(90451,BJPCX,0),U)
+5 SET BJPCP=$PIECE($GET(^BKM(90451,BJPCX,1,BJPCY,3)),U)
IF BJPCP
Begin DoDot:3
+6 DO AEDAP^BDPAPI(DFN,BJPCP,"HIV PROVIDER",.BJPCR)
+7 IF 'BJPCR
DO MES^XPDUTL("Error copying HIV Provider for "_DFN)
End DoDot:3
+8 SET BJPCP=$PIECE($GET(^BKM(90451,BJPCX,1,BJPCY,3)),U,2)
IF BJPCP
Begin DoDot:3
+9 DO AEDAP^BDPAPI(DFN,BJPCP,"HIV CASE MANAGER",.BJPCR)
+10 IF 'BJPCR
DO MES^XPDUTL("Error copying HIV Case manager for "_DFN)
End DoDot:3
End DoDot:2
End DoDot:1
EXAMINAC ;
+1 ;inactivate exams 23, 08, 05
+2 DO MES^XPDUTL("Inactivating Exam Codes")
+3 SET DA=$ORDER(^AUTTEXAM("C","23",0))
IF DA
SET DIE="^AUTTEXAM("
SET DR=".04////1"
DO ^DIE
KILL DA,DIE,DR
+4 SET DA=$ORDER(^AUTTEXAM("C","08",0))
IF DA
SET DIE="^AUTTEXAM("
SET DR=".04////1"
DO ^DIE
KILL DA,DIE,DR
+5 SET DA=$ORDER(^AUTTEXAM("C","05",0))
IF DA
SET DIE="^AUTTEXAM("
SET DR=".04////1"
DO ^DIE
KILL DA,DIE,DR
HMRSTAT ;
+1 ;PUT STATUS BACK IN
+2 SET APCHX=0
FOR
SET APCHX=$ORDER(^APCHTMP("HMR STATUS",APCHX))
IF APCHX'=+APCHX
QUIT
Begin DoDot:1
+3 ;,DIC="^APCHSURV(",DIC(0)="M" D ^DIC
SET X=$PIECE(^APCHTMP("HMR STATUS",APCHX),U)
SET APCHS=$PIECE(^APCHTMP("HMR STATUS",APCHX),U,2)
+4 ;I Y=-1 W !!,"could not update status on ",X," hmr" Q
+5 IF '$DATA(^APCHSURV(APCHX,0))
QUIT
+6 IF $PIECE(^APCHSURV(APCHX,0),U,3)'="D"
SET $PIECE(^APCHSURV(APCHX,0),U,3)=APCHS
End DoDot:1
+7 KILL ^APCHTMP("HMR STATUS")
ASMSMP ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Copying Asthma Management Plan to V Patient Education.",IOM))
+2 SET X=0
SET BJPCIEN=""
FOR
SET X=$ORDER(^AUTTEDT("C","ASM-SMP",X))
IF X'=+X!(BJPCIEN)
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUTTEDT(X,0))
QUIT
+4 IF $PIECE(^AUTTEDT(X,0),U,3)
QUIT
+5 SET BJPCIEN=X
End DoDot:1
+6 IF 'BJPCIEN
DO MES^XPDUTL($$CJ^XLFSTR("ASM-SMP education topic missing from file, cannot move data.",IOM))
GOTO HF
+7 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNVAST(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+8 ;no asthma management plan to copy
IF $PIECE($GET(^AUPNVAST(BJPCX,0)),U,12)=""
QUIT
+9 IF $PIECE($GET(^AUPNVAST(BJPCX,0)),U,12)'=1
QUIT
+10 IF $$HASASAMP($PIECE(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
QUIT
+11 KILL APCDALVR
+12 SET APCDALVR("APCDVSIT")=$PIECE(^AUPNVAST(BJPCX,0),U,3)
+13 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.16 (ADD)]"
+14 SET APCDALVR("APCDTTOP")="`"_BJPCIEN
+15 SET APCDALVR("APCDPAT")=$PIECE(^AUPNVAST(BJPCX,0),U,2)
+16 DO ^APCDALVR
+17 IF $DATA(APCDALVR("APCDAFLG"))
DO MES^XPDUTL($$CJ^XLFSTR("Patient ed ASM-SMP failed for Visit "_$PIECE(^AUPNVAST(BJPCX,0),U,3),IOM))
+18 KILL APCDALVR
End DoDot:1
HF ;
+1 DO MES^XPDUTL("Updating HEALTH FACTOR table")
+2 DO ^BJPC2EVH
+3 ;update problem list classification from latest v asthma stage
DO ^BJPC2EV2
RHC ;
+1 DO CONVRH^AUPNREP
+2 ;REINDEX ALM xref
+3 NEW DIK
+4 SET DIK="^AUPNVDEN("
SET DIK(1)="1209^AXK"
DO ENALL^DIK
KILL DIK
+5 ;
+6 ;D WRITEMSG
+7 QUIT
WRITEMSG ;
+1 SET X=$ORDER(^APCLPDES("B","BJPCV2",0))
+2 IF 'X
QUIT
+3 SET Y=0
FOR
SET Y=$ORDER(^APCLPDES(X,11,Y))
IF Y'=+Y
QUIT
SET ^TMP($JOB,"BJPCBUL",Y)=^APCLPDES(X,11,Y,0)
+4 QUIT
+5 ;
GETRECIP ;
+1 ;
+2 SET CTR=0
+3 FOR BJPCKEY="APCLZMENU","APCDZMENU","APCHZMENU","BDPZMENU","AMQQZMENU"
+4 FOR
SET CTR=$ORDER(^XUSEC(BJPCKEY,CTR))
IF 'CTR
QUIT
SET Y=CTR
SET XMY(Y)=""
+5 QUIT
INSTALLD(BJPCSTAL) ;EP - Determine if patch BJPCSTAL was installed, where
+1 ; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 ;
+3 NEW BJPCY,DIC,X,Y
+4 SET X=$PIECE(BJPCSTAL,"*",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(BJPCSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
DO IMES
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(BJPCSTAL,"*",3)
+12 DO ^DIC
+13 SET BJPCY=Y
+14 DO IMES
+15 QUIT $SELECT(BJPCY<1:0,1:1)
IMES ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BJPCSTAL_""" 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
+6 ;
LABTAX ;EP
+1 SET BJPCX="APCH FECAL OCCULT BLOOD"
SET BJPCPG="APCH"
SET BJPCAP=0
DO LAB1
+2 SET BJPCX="APCH HCT/HGB TESTS"
SET BJPCPG="APCH"
SET BJPCAP=0
DO LAB1
+3 SET BJPCX="DM AUDIT 2 HR GTT TAX"
SET BJPCPG="BDM,APCL,APCH"
SET BJPCAP=0
DO LAB1
+4 SET BJPCX="DM AUDIT 75GM 2HR GLUCOSE"
SET BJPCPG="BDM,APCL,APCH"
SET BJPCAP=0
DO LAB1
+5 SET BJPCX="DM AUDIT A/C RATIO TAX"
SET BJPCPG="BDM,APCL,BGP,APCH"
SET BJPCAP=0
DO LAB1
+6 SET BJPCX="DM AUDIT AST TAX"
SET BJPCPG="BDM,APCL,BGP,APCH"
SET BJPCAP=0
DO LAB1
+7 SET BJPCX="DM AUDIT ALT TAX"
SET BJPCPG="BDM,APCL,BGP,APCH"
SET BJPCAP=0
DO LAB1
+8 SET BJPCX="DM AUDIT CHOLESTEROL TAX"
SET BJPCPG="BDM,APCL,BGP,APCH"
SET BJPCAP=0
DO LAB1
+9 SET BJPCX="DM AUDIT CREATININE TAX"
SET BJPCPG="BDM,APCL,BGP,APCH"
SET BJPCAP=0
DO LAB1
+10 SET BJPCX="DM AUDIT FASTING GLUCOSE TESTS"
SET BJPCPG="BDM,APCL,BGP,APCH"
SET BJPCAP=0
DO LAB1
+11 SET BJPCX="DM AUDIT GLUCOSE TESTS TAX"
SET BJPCPG="BDM,APCL,BGP,APCH"
SET BJPCAP=0
DO LAB1
+12 SET BJPCX="DM AUDIT HDL TAX"
SET BJPCPG="BDM,APCL,BGP,APCH"
SET BJPCAP=0
DO LAB1
+13 SET BJPCX="DM AUDIT HGB A1C TAX"
SET BJPCPG="BDM,APCL,BGP,APCH"
SET BJPCAP=0
DO LAB1
+14 SET BJPCX="DM AUDIT LDL CHOLESTEROL TAX"
SET BJPCPG="BDM,APCL,BGP,APCH"
SET BJPCAP=0
DO LAB1
+15 SET BJPCX="DM AUDIT MICROALBUMINURIA TAX"
SET BJPCPG="BDM,APCL,BGP,APCH"
SET BJPCAP=0
DO LAB1
+16 SET BJPCX="DM AUDIT P/C RATIO TAX"
SET BJPCPG="BDM,APCL,APCH"
SET BJPCAP=0
DO LAB1
+17 SET BJPCX="DM AUDIT TRIGLYCERIDE TAX"
SET BJPCPG="BDM,APCL,BGP,APCH"
SET BJPCAP=0
DO LAB1
+18 SET BJPCX="DM AUDIT URINALYSIS TAX"
SET BJPCPG="BDM,APCL,BGP,APCH"
SET BJPCAP=1
DO LAB1
+19 SET BJPCX="DM AUDIT URINE PROTEIN TAX"
SET BJPCPG="BDM,APCL,BGP,APCH"
SET BJPCAP=0
DO LAB1
+20 QUIT
+21 ;
LAB1 ;
+1 SET BJPCDA=$ORDER(^ATXLAB("B",BJPCX,0))
+2 ;taxonomy already exists
IF BJPCDA
GOTO UP41
+3 WRITE !,"Creating ",BJPCX," Taxonomy..."
+4 SET X=BJPCX
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 ",BJPCX," TAX"
QUIT
+6 SET BJPCDA=+Y
SET $PIECE(^ATXLAB(BJPCDA,0),U,2)=BJPCX
SET $PIECE(^(0),U,5)=DUZ
SET $PIECE(^(0),U,6)=DT
SET $PIECE(^(0),U,8)="B"
SET $PIECE(^(0),U,9)=60
SET $PIECE(^(0),U,22)=0
SET $PIECE(^(0),U,4)="n"
SET $PIECE(^(0),U,11)=BJPCAP
+7 SET ^ATXLAB(BJPCDA,21,0)="^9002228.02101PA^0^0"
+8 SET DA=BJPCDA
SET DIK="^ATXAX("
DO IX1^DIK
UP41 ;
+1 FOR BJPCI=1:1
SET BJPCPI=$PIECE(BJPCPG,",",BJPCI)
IF BJPCPI=""
QUIT
Begin DoDot:1
+2 SET BJPCPI=$ORDER(^DIC(9.4,"C","BJPC",0))
+3 ;NO PACKAGE
IF BJPCPI=""
QUIT
+4 IF $DATA(^ATXLAB(BJPCDA,41,"B",BJPCPI))
QUIT
+5 SET X="`"_BJPCPI
SET DIC="^ATXLAB("_BJPCDA_",41,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9002228,4101,0),U,2)
SET DA(1)=BJPCDA
+6 DO ^DIC
+7 IF Y=-1
WRITE !,"updating package multiple for ",BJPCPI," entry ",$PIECE(^ATXAX(BJPCDA,0),U)," failed"
+8 KILL DIC,DA,Y,X
End DoDot:1
+9 QUIT
+10 ;
DMADA ;
+1 SET ATXFLG=1
+2 WRITE !,"Updating APCH ADA Codes Taxonomy..."
+3 SET BJPCTX=0
SET BJPCTX=$ORDER(^ATXAX("B","APCH DM ADA EXAMS",BJPCTX))
+4 IF BJPCTX
GOTO TX1
+5 SET X="APCH DM ADA EXAMS"
SET DIC="^ATXAX("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002226
DO ^DIC
KILL DIC,DA,DIADD,DLAYGO,I
IF Y=-1
WRITE !!,"ERROR IN CREATING APCH DM ADA EXAMS TAXONOMY"
QUIT
+6 SET BJPCTX=+Y
SET $PIECE(^ATXAX(BJPCTX,0),U,2)="ADA CODES FOR DM EXAM"
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(BJPCTX,21,0)="^9002226.02101A^0^0"
TX1 SET BJPCTEXT="ADA"
FOR BJPCX=1:1:5
SET X=$PIECE($TEXT(@BJPCTEXT+BJPCX),";;",2)
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
+1 ;this code is already there.
SET Y=+Y
IF $DATA(^ATXAX(BJPCTX,21,"B",Y))
QUIT
+2 SET BJPCL=0
SET BJPCY=0
FOR
SET BJPCY=$ORDER(^ATXAX(BJPCTX,21,BJPCY))
IF BJPCY'=+BJPCY
QUIT
SET BJPCL=BJPCY
+3 SET BJPCL=BJPCL+1
SET ^ATXAX(BJPCTX,21,BJPCL,0)=Y
SET $PIECE(^ATXAX(BJPCTX,21,BJPCL,0),U,2)=Y
SET $PIECE(^ATXAX(BJPCTX,21,0),U,3)=BJPCL
SET $PIECE(^(0),U,4)=BJPCL
SET ^ATXAX(BJPCTX,21,"AA",Y,Y)=""
SET ^ATXAX(BJPCTX,21,"B",Y,BJPCL)=""
+4 QUIT
End DoDot:1
+5 SET DA=BJPCTX
SET DIK="^ATXAX("
DO IX1^DIK
+6 KILL BJPCTX,BJPCDA,BJPCTEXT,ATXFLG
+7 QUIT
+8 ;
MEDTAX ;EP set up drug taxonomies
+1 SET ATXFLG=1
+2 SET BJPCX="DM AUDIT ASPIRIN DRUGS"
SET BJPCPG="BDM,APCH,APCL"
DO DRUG1
+3 SET BJPCX="DM AUDIT ACARBOSE DRUGS"
SET BJPCPG="BDM,APCH,APCL"
DO DRUG1
+4 SET BJPCX="DM AUDIT ACE INHIBITORS"
SET BJPCPG="BDM,APCH,APCL"
DO DRUG1
+5 SET BJPCX="DM AUDIT ANTI-PLATELET DRUGS"
SET BJPCPG="BDM,APCH,APCL"
DO DRUG1
+6 SET BJPCX="DM AUDIT DPP4 INHIBITOR DRUGS"
SET BJPCPG="BDM,APCH,APCL"
DO DRUG1
+7 SET BJPCX="DM AUDIT GLITAZONE DRUGS"
SET BJPCPG="BDM,APCH,APCL"
DO DRUG1
+8 SET BJPCX="DM AUDIT INCRETIN MIMETIC"
SET BJPCPG="BDM,APCH,APCL"
DO DRUG1
+9 SET BJPCX="DM AUDIT INSULIN DRUGS"
SET BJPCPG="BDM,APCH,APCL"
DO DRUG1
+10 SET BJPCX="DM AUDIT LIPID LOWERING DRUGS"
SET BJPCPG="BDM,APCH,APCL"
DO DRUG1
+11 SET BJPCX="DM AUDIT METFORMIN DRUGS"
SET BJPCPG="BDM,APCH,APCL"
DO DRUG1
+12 SET BJPCX="DM AUDIT ORAL HYPOGLYCEMICS"
SET BJPCPG="BDM,APCH,APCL"
DO DRUG1
+13 SET BJPCX="DM AUDIT SELF MONITOR DRUGS"
SET BJPCPG="BDM,APCH,APCL"
DO DRUG1
+14 SET BJPCX="DM AUDIT STATIN DRUGS"
SET BJPCPG="BDM,APCH,APCL"
DO DRUG1
+15 SET BJPCX="DM AUDIT SULFONYLUREA DRUGS"
SET BJPCPG="BDM,APCH,APCL"
DO DRUG1
+16 SET BJPCX="BAT ASTHMA SHRT ACT RELV MEDS"
SET BJPCNDCT="BAT ASTHMA SHRT ACT RELV NDC"
SET BJPCTAX=""
SET BJPCPG="APCH;BJPC"
DO DRUG1
+17 SET BJPCX="BAT ASTHMA SHRT ACT INHLR MEDS"
SET BJPCNDCT="BAT ASTHMA SHRT ACT INHLR NDC"
SET BJPCTAX=""
SET BJPCPG="APCH;BJPC"
DO DRUG1
+18 SET BJPCX="BAT ASTHMA LEUKOTRIENE MEDS"
SET BJPCNDCT="BAT ASTHMA LEUKOTRIENE NDC"
SET BJPCTAX=""
SET BJPCPG="APCH;BJPC"
DO DRUG1
+19 SET BJPCX="BAT ASTHMA CONTROLLER MEDS"
SET BJPCNDCT="BAT ASTHMA CONTROLLER NDC"
SET BJPCTAX=""
SET BJPCPG="APCH;BJPC"
DO DRUG1
+20 SET BJPCX="BAT ASTHMA INHALED STEROIDS"
SET BJPCNDCT="BAT ASTHMA INHLD STEROIDS NDC"
SET BJPCTAX=""
SET BJPCPG="APCH;BJPC"
DO DRUG1
+21 SET BJPCX="BGP RA GLUCOCORTICOIDS MEDS"
SET BJPCTAX="BGP RA GLUCOCORTICOIDS CLASS"
SET BJPCNDCT=""
SET BJPCPG="APCH;BJPC"
DO DRUG1
+22 QUIT
+23 ;
DRUG1 ;
+1 SET BJPCTX=$ORDER(^ATXAX("B",BJPCX,0))
+2 IF 'BJPCTX
Begin DoDot:1
+3 DO MES^XPDUTL("Creating "_BJPCX_" taxonomy")
+4 SET X=BJPCX
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 ",BJPCX," TAX"
QUIT
+6 SET BJPCTX=+Y
SET $PIECE(^ATXAX(BJPCTX,0),U,2)=BJPCX
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 $PIECE(^(0),U,22)=0
SET $PIECE(^(0),U,4)="n"
SET ^ATXAX(BJPCTX,21,0)="^9002226.02101A^0^0"
End DoDot:1
IF Y=-1
QUIT
+7 SET DA=BJPCTX
SET DIK="^ATXAX("
DO IX1^DIK
+8 DO MES^XPDUTL("Updating "_BJPCX_" taxonomy")
+9 IF $GET(BJPCTAX)]""
Begin DoDot:1
+10 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BJPCTX,21,A))
IF A'=+A
QUIT
SET B=A
+11 SET BJPCC=B
+12 SET ^ATXAX(BJPCTX,21,0)="^9002226.02101A^"_B_U_B
+13 SET Z=$ORDER(^ATXAX("B",BJPCTAX,0))
+14 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
+15 IF $DATA(^ATXAX(BJPCTX,21,"B",J))
QUIT
+16 SET BJPCC=BJPCC+1
SET ^ATXAX(BJPCTX,21,BJPCC,0)=J_U_J
End DoDot:2
End DoDot:1
+17 IF $GET(BJPCNDCT)]""
Begin DoDot:1
+18 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BJPCTX,21,A))
IF A'=+A
QUIT
SET B=A
+19 SET BJPCC=B
+20 SET ^ATXAX(BJPCTX,21,0)="^9002226.02101A^"_B_U_B
+21 SET Z=$ORDER(^ATXAX("B",BJPCNDCT,0))
+22 SET J=0
FOR
SET J=$ORDER(^PSDRUG(J))
IF J'=+J
QUIT
SET C=$PIECE($GET(^PSDRUG(J,2)),U,4)
IF C]""
IF $DATA(^ATXAX(Z,21,"B",C))
Begin DoDot:2
+23 IF $DATA(^ATXAX(BJPCTX,21,"B",J))
QUIT
+24 SET BJPCC=BJPCC+1
SET ^ATXAX(BJPCTX,21,BJPCC,0)=J_U_J
End DoDot:2
End DoDot:1
+25 SET DA=BJPCTX
SET DIK="^ATXAX("
DO IX1^DIK
+26 QUIT
+27 ;
UP41M ;
+1 FOR BJPCI=1:1
SET BJPCPI=$PIECE(BJPCPG,",",BJPCI)
IF BJPCPI=""
QUIT
Begin DoDot:1
+2 KILL DIC,DA,DR
+3 SET BJPCPI=$ORDER(^DIC(9.4,"C","BJPC",0))
+4 ;NO PACKAGE
IF BJPCPI=""
QUIT
+5 IF $DATA(^ATXAX(BJPCTX,41,"B",BJPCPI))
QUIT
+6 SET X="`"_BJPCPI
SET DIC="^ATXAX("_BJPCTX_",41,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9002226,4101,0),U,2)
SET DA(1)=BJPCTX
+7 DO ^DIC
+8 IF Y=-1
WRITE !,"updating package multiple for ",BJPCPI," entry ",$PIECE(^ATXAX(BJPCTX,0),U)," failed"
+9 KILL DIC,DA,Y,X
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
UPDTAXR ;
+1 ;update read only field and nodelete field for all taxonomies
+2 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^APCCTXC(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+3 SET BJPCR=$PIECE(^APCCTXC(BJPCX,0),U,2)
SET BJPCND=$PIECE(^APCCTXC(BJPCX,0),U,3)
SET BJPCN=$PIECE(^APCCTXC(BJPCX,0),U)
+4 SET DA=$ORDER(^ATXAX("B",BJPCN,0))
IF DA
SET DIE="^ATXAX("
SET DR=".04///"_BJPCND_";.22///"_BJPCR
DO ^DIE
KILL DA,DIE,DR
+5 QUIT
End DoDot:1
+6 QUIT
HASASAMP(V,I) ;is there a v patient ed of ASM-SMP?
+1 NEW X,Y,Z
+2 SET (X,Z)=0
FOR
SET X=$ORDER(^AUPNVPED("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^AUPNVPED(X,0)),U)=I
SET Z=1
+4 QUIT
End DoDot:1
+5 QUIT Z
+6 ;
ADA ;
+1 ;;0120
+2 ;;0150
+3 ;;0114
+4 ;;9320
+5 ;;9321
+6 ;;
