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

BJPC2P1.m

Go to the documentation of this file. 
  1. BJPC2P1 ; IHS/CMI/LAB - PCC Suite v1.0 patch 1 environment check ;   
  1.  ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
  1.  ;
  1.  ;
  1.  ; The following line prevents the "Disable Options..." and "Move 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("APCL*3.0*24") D SORRY(2)
  1.  I $$VERSION^XPDUTL("BJPC")'="2.0" D SORRY(2)
  1.  ;
  1.  Q
  1.  ;
  1. PRE ;
  1.  S BJPCDA=0 F  S BJPCDA=$O(^APCLVSTS(BJPCDA)) Q:BJPCDA'=+BJPCDA  S DA=BJPCDA,DIK="^APCLVSTS(" D ^DIK
  1.  S BJPCDA=0 F  S BJPCDA=$O(^APCDTHFD(BJPCDA)) Q:BJPCDA'=+BJPCDA  S DA=BJPCDA,DIK="^APCDTHFD(" D ^DIK
  1.  ;delete v telehealth and v nutr screening
  1.  S DIU(0)="",DIU=9000010.48 D EN^DIU2
  1.  S DIU(0)="",DIU=9000010.49 D EN^DIU2
  1.  K DIU
  1.  K ^APCHTMP("HMR STATUS")
  1.  S X=0 F  S X=$O(^APCHSURV(X)) Q:X'=+X  S ^APCHTMP("HMR STATUS",X)=$P(^APCHSURV(X,0),U)_U_$P(^APCHSURV(X,0),U,3)
  1.  ;change name of medications pwh component
  1.  S DA=$O(^APCHPWHC("B","MEDICATIONS",0))
  1.  I DA S DIE="^APCHPWHC(",DR=".01///MEDICATIONS (ACTIVE AND RECENTLY EXPIRED)" D ^DIE K DA,DIE,DR
  1.  D PRE^AMQQPOST
  1.  Q
  1. POST ;
  1. OPTIONS ;
  1. HMRSTAT ;
  1.  ;rename optiom
  1.  S DA=$O(^DIC(19,"B","APCL P PATLIST DP-W/ V COUNTS",0))
  1.  I DA S DIE="^DIC(19,",DR="1///Pts by Designated Primary Care Prov w/Visit Counts" D ^DIE K DA,DIE,DR
  1.  ;PUT STATUS BACK IN
  1.  S DA=$O(^DIC(19,"B","APCL P PATLIST DESIG PROV",0))
  1.  I DA S DIE="^DIC(19,",DR="1///Patient Listing by Designated Primary Care Prov" D ^DIE K DA,DIE,DR
  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.  S X=$$ADD^XPDMENU("APCD MENU ENTER DATA","APCD RESEQUENCE POVS","RSPV")
  1.  I 'X W "Attempt to add APCD RESEQUENCE POVS option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCD UPD PAT RELATED DATA","APCD TREATMENT PLAN","TP")
  1.  I 'X W "Attempt to add APCD TREATMENT PLAN option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCH MENU HEALTH MAINTENANCE","APCH LIST HMRS","LHMR")
  1.  I 'X W "Attempt to add APCH LIST HMRS option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCDCAF EHR CODING AUDIT MENU","APCDCAF AUTO COMPLETE/CLINIC","ACCL")
  1.  I 'X W "Attempt to add AUTO COMPLETE BY CLINIC option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCDCAF EHR CODING AUDIT MENU","APCDCAF NOT REVIEWED IN N DAYS","VNR")
  1.  I 'X W "Attempt to add APCDCAF NOT REVIEWED IN N DAYS option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCD PRINT MENU","APCD PROVIDER LISTING","PRVL",1)
  1.  I 'X W "Attempt to add APCD PROVIDER LISTING option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCL M MAN QUALITY ASSURANCE","APCL ANTICOAG REPORT","AC",1)
  1.  I 'X W "Attempt to add ANTI COAG REPORT option failed.." H 3
  1.  ;
  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.  ;inactivate NON-TOBACCO USER
  1.  S DA=$O(^AUTTHF("B","NON-TOBACCO USER",0)) I DA S DIE="^AUTTHF(",DR=".13////1;.15////"_DT D ^DIE K DA,DIE,DR
  1.  S DA=$O(^AUTTHF("B","READINESS TO LEARN",0)) I DA S DIE="^AUTTHF(",DR=".13////1;.15////"_DT D ^DIE K DA,DIE,DR
  1.  S DA=$O(^AUTTHF("B","STAGED DIABETES MANAGEMENT",0)) I DA S DIE="^AUTTHF(",DR=".13////1;.15////"_DT D ^DIE K DA,DIE,DR
  1.  D ^BJPC2EVH
  1.  ;add new ones
  1.  D ^BJPC2EV2  ;update problem list classification from latest v asthma stage
  1.  D ^BJPCPT
  1.  D LABTAX
  1.  D POST^AMQQPOST
  1.  ;reindex AA, AAC on V Asthma
  1.  S DIK="^AUPNVAST(",DIK(1)=".14^AAC" D ENALL^DIK
  1.  S DIK="^AUPNVAST(",DIK(1)=".03^AA" D ENALL^DIK
  1.  K DIK
  1.  ;change DP and PCP in mnemonics
  1.  S DA=$O(^APCDTKW("B","DP",0))
  1.  I DA S DIE="^APCDTKW(",DR=".06///Designated Primary Care Prov"_";.12///Designated PCP" D ^DIE K DA,DIE,DR
  1.  S DA=$O(^APCDTKW("B","PCP",0))
  1.  I DA S DIE="^APCDTKW(",DR=".06///Designated Primary Care Prov"_";.12///Designated PCP" D ^DIE K DA,DIE,DR
  1.  ;
  1.  Q
  1. WRITEMSG ;
  1.  S X=$O(^APCLPDES("B","BJPCV2P1",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. 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. LABTAX ;
  1.  S BJPCX="BJPC INR LAB TESTS",BJPCPG="APCH;BJPC;APCL",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