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

BJPC2ENV.m

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