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

BJPC2PMU.m

Go to the documentation of this file.
  1. BJPC2PMU ; IHS/CMI/LAB - PCC Suite v2.0 patch 10 environment check ;
  1. ;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
  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. ;KERNEL
  1. I +$$VERSION^XPDUTL("XU")<8 D MES^XPDUTL($$CJ^XLFSTR("Version 8.0 of KERNEL is required. Not installed",80)) D SORRY(2) I 1
  1. E D MES^XPDUTL($$CJ^XLFSTR("Requires Kernel Version 8.0....Present.",80))
  1. ;FILEMAN
  1. I +$$VERSION^XPDUTL("DI")<22 D MES^XPDUTL($$CJ^XLFSTR("Version 22.0 of FILEMAN is required. Not installed.",80)) D SORRY(2) I 1
  1. E D MES^XPDUTL($$CJ^XLFSTR("Requires Fileman v22....Present.",80))
  1. ;BJPC
  1. I $$VERSION^XPDUTL("BJPC")'="2.0" D MES^XPDUTL($$CJ^XLFSTR("Version 2.0 of the IHS PCC SUITE (BJPC) is required. Not installed",80)) D SORRY(2) I 1
  1. E D MES^XPDUTL($$CJ^XLFSTR("Requires IHS PCC Suite (BJPC) Version 2.0....Present.",80))
  1. I '$$INSTALLD("BJPC*2.0*8") D SORRY(2)
  1. I '$$INSTALLD("BJPC*2.0*9") D SORRY(2)
  1. I '$$INSTALLD("AVA*93.2*22") D SORRY(2)
  1. I '$$INSTALLD("AUT*98.1*26") D SORRY(2)
  1. I '$$INSTALLD("AUPN*99.1*23") D SORRY(2)
  1. I '$$INSTALLD("AUM*13.0*2") D SORRY(2)
  1. I '$$INSTALLD("AUM*13.0*3") D SORRY(2)
  1. I +$$VERSION^XPDUTL("BCQM")<1 D MES^XPDUTL($$CJ^XLFSTR("Version 1.0 of BCQM - IHS CODE MAPPING is required. Not installed",80)) D SORRY(2) I 1
  1. E D MES^XPDUTL($$CJ^XLFSTR("Requires BCQM V1.0....Present.",80))
  1. I +$$VERSION^XPDUTL("BSTS")<1 D MES^XPDUTL($$CJ^XLFSTR("Version 1.0 of BSTS - IHS TERMINOLOGY is required. Not installed",80)) D SORRY(2) I 1
  1. E D MES^XPDUTL($$CJ^XLFSTR("Requires BSTS V1.0....Present.",80))
  1. I '$$INSTALLD("AG*7.1*11") D SORRY(2)
  1. Q
  1. PRE ;
  1. ;get rid of v care planning
  1. S DIU=9000010.57,DIU(0)="DET" D EN^DIU2 K DIU
  1. S DIU=9000010.59,DIU(0)="E" D EN^DIU2 K DIU
  1. S DIU=9000010.61,DIU(0)="E" D EN^DIU2 K DIU
  1. S DIU=9000010.63,DIU(0)="E" D EN^DIU2 K DIU
  1. S DA=$O(^AUTTREFR("B","410561003",0))
  1. I DA S DIE="^AUTTREFR(",DR=".01///410534003" D ^DIE K DA,DR,DIE
  1. S BJPCOS=$O(^APCHSURV("B","OSTEOPOROSIS SCREENING",0))
  1. I BJPCOS S BJPCOS=$P(^APCHSURV(BJPCOS,0),U,3)
  1. ;FIX 2101 MULTIPLE IN REPRODUCTIVE FACTORS
  1. S DA=0 F S DA=$O(^AUPNREP(DA)) Q:DA'=+DA D
  1. .Q:'$D(^AUPNREP(DA,2101,0))
  1. .I $P(^AUPNREP(DA,2101,0),U,2)="S" S $P(^AUPNREP(DA,2101,0),U,2)="9000017.0201PA"
  1. Q
  1. ;
  1. POST ;
  1. ;add refusal type SNOMED to refusal type file
  1. I '$D(^AUTTREFT("B","SNOMED")) D
  1. .K DIC,DR,D0,DO
  1. .S X="SNOMED",DIC="^AUTTREFT(",DIC("DR")=".02////9002318.4;.03////1",DIC(0)="L",DIADD=1,DLAYGO=9999999.73 D FILE^DICN K DIC,DIADD,DLAYGO
  1. ;add message agent if it isn't there
  1. I '$D(^BDPTCAT("B","MESSAGE AGENT")) D
  1. .S X="MESSAGE AGENT",DIC="^BDPTCAT(",DIC(0)="L",DIADD=1,DLAYGO=90360.3,DIC("DR")=".02///MA;.07///1;.06///0;.08///Y" D FILE^DICN K DIC,DIADD,DLAYGO
  1. .Q
  1. ;
  1. ;ADD OPTIONS TO BDP
  1. S X=$$ADD^XPDMENU("BDP MENU MANAGER","BDP ADD/EDIT MESSAGE AGENT","MA",5)
  1. S X=$$ADD^XPDMENU("BDP MENU MANAGER","BDP INACT/REACT MESSAGE AGENT","IMA",10)
  1. S X=$$ADD^XPDMENU("BDP MENU DE","BDP ASSIGN MESSAGE AGENT","AMA")
  1. D FHAGE
  1. D ^BJPC2M
  1. S ^AMQQ(1,2,4,1,1)="S X=$S(X=""M"":""MALE"",X=""F"":""FEMALE"",X=""U"":""UNKNOWN"",1:"""")" ;change sex output transform
  1. D PNEU
  1. D MES^XPDUTL($$CJ^XLFSTR("Hold on..I have to do some back-filling of SNOMED codes...",80))
  1. SNO D TOBSMIM ;HEALTH FACTORS FOREVER/IMM ;to background
  1. D URMEAS ;UPDATE/REVIEWED AND MEAS BACK 1 YR ;to background
  1. D NBHEAR ;FOREGROUND
  1. D INFANT ;FOREGROUND ;v infant feeding and exams
  1. T ;BACKFILL 1.01 IN PATIENT REFUSALS
  1. I '$P($G(^APCCCTRL(DUZ(2),99999)),U,1) S DIK="^AUPNPREF(",DIK(1)=".07^ASNMMAP" D ENALL^DIK S $P(^APCCCTRL(DUZ(2),99999),U,1)=1
  1. S X=$O(^APCHSURV("B","OSTEOPOROSIS SCREENING",0))
  1. I X S $P(^APCHSURV(X,0),U,3)=BJPCOS
  1. Q
  1. PNEU ;
  1. ;mark Influenza and Pneumovax reminders as Deleted.
  1. S DA=$O(^APCHSURV("B","INFLUENZA",0))
  1. I DA S DIE="^APCHSURV(",DR=".03////D" D ^DIE K DIE,DA,DR
  1. S DA=$O(^APCHSURV("B","PNEUMOVAX",0))
  1. I DA S DIE="^APCHSURV(",DR=".03////D" D ^DIE K DIE,DA,DR
  1. S BJPCX=0 F S BJPCX=$O(^APCHSURV(BJPCX)) Q:BJPCX'=+BJPCX D
  1. .I $P($G(^APCHSURV(BJPCX,0)),U,1)="ANTICOAGULATION: SAFETY MEASURE: URINALYSIS" D
  1. ..S DA=BJPCX S DIE="^APCHSURV(",DR=".03////D" D ^DIE K DIE,DA,DR
  1. .I $P($G(^APCHSURV(BJPCX,0)),U,1)="ANTICOAGULATION: SAFETY MEASURE: CBC" D
  1. ..S DA=BJPCX S DIE="^APCHSURV(",DR=".03////D" D ^DIE K DIE,DA,DR
  1. .I $P($G(^APCHSURV(BJPCX,0)),U,1)="ANTICOAGULATION: SAFETY MEASURE: FOBT" D
  1. ..S DA=BJPCX S DIE="^APCHSURV(",DR=".03////D" D ^DIE K DIE,DA,DR
  1. Q
  1. TOBSMIM ;
  1. ;backfill snomed for tobacco categories health factors and v imm
  1. S ZTIO=""
  1. S ZTRTN="TOBSM1^BJPC2PMU",ZTDTH=$$NOW^XLFDT,ZTDESC="BACKFILL V HEALTH FACTORS WITH SNOMED" D ^%ZTLOAD
  1. Q
  1. TOBSM1 ;
  1. S BJPCX=0
  1. F S BJPCX=$O(^AUPNVHF(BJPCX)) Q:BJPCX'=+BJPCX D
  1. .S DA=BJPCX
  1. .D HF^AUPNMAP
  1. .Q
  1. D IMM1
  1. Q
  1. IMM1 ;
  1. S BJPCX=0
  1. F S BJPCX=$O(^AUPNVIMM(BJPCX)) Q:BJPCX'=+BJPCX D
  1. .S DA=BJPCX
  1. .D IMM^AUPNMAP
  1. .Q
  1. Q
  1. NBHEAR ;
  1. S BJPCD=$O(^AUTTEXAM("C",38,0))
  1. S BJPCX=0
  1. F S BJPCX=$O(^AUPNVXAM("B",BJPCD,BJPCX)) Q:BJPCX'=+BJPCX D
  1. .Q:'$D(^AUPNVXAM(BJPCX,0))
  1. .S DA=BJPCX
  1. .D EXAM^AUPNMAP
  1. .Q
  1. S BJPCD=$O(^AUTTEXAM("C",39,0))
  1. S BJPCX=0
  1. F S BJPCX=$O(^AUPNVXAM("B",BJPCD,BJPCX)) Q:BJPCX'=+BJPCX D
  1. .Q:'$D(^AUPNVXAM(BJPCX,0))
  1. .S DA=BJPCX
  1. .D EXAM^AUPNMAP
  1. .Q
  1. Q
  1. INFANT ;
  1. S BJPCD=$$FMADD^XLFDT(DT,(5*366)) ;go back about 5 years
  1. F S BJPCD=$O(^AUPNVSIT("B",BJPCD)) Q:BJPCD="" D
  1. .S BJPCV=0 F S BJPCV=$O(^AUPNVSIT("B",BJPCD,BJPCV)) Q:BJPCV'=+BJPCV D
  1. ..S BJPCX=0
  1. ..F S BJPCX=$O(^AUPNVIF("AD",BJPCV,BJPCX)) Q:BJPCX'=+BJPCX D
  1. ...Q:'$D(^AUPNVIF(BJPCX,0))
  1. ...S DA=BJPCX
  1. ...D IF^AUPNMAP
  1. ...Q
  1. Q
  1. URMEAS ;
  1. ;backfill snomed for updated/reviewed/exam and meas for 1 year
  1. S ZTIO=""
  1. S ZTRTN="URMEAS1^BJPC2PMU",ZTDTH=$$NOW^XLFDT,ZTDESC="BACKFILL V UPDATED/MEAS WITH SNOMED" D ^%ZTLOAD
  1. Q
  1. URMEAS1 ;
  1. S BJPCD=$$FMADD^XLFDT(DT,-367) ;go back about a year
  1. F S BJPCD=$O(^AUPNVSIT("B",BJPCD)) Q:BJPCD="" D
  1. .S BJPCV=0 F S BJPCV=$O(^AUPNVSIT("B",BJPCD,BJPCV)) Q:BJPCV'=+BJPCV D
  1. ..S BJPCX=0
  1. ..F S BJPCX=$O(^AUPNVRUP("AD",BJPCV,BJPCX)) Q:BJPCX'=+BJPCX D
  1. ...Q:'$D(^AUPNVRUP(BJPCX,0))
  1. ...S DA=BJPCX
  1. ...D UPDREV^AUPNMAP
  1. ...Q
  1. ..S BJPCX=0
  1. ..F S BJPCX=$O(^AUPNVMSR("AD",BJPCV,BJPCX)) Q:BJPCX'=+BJPCX D
  1. ...Q:'$D(^AUPNVMSR(BJPCX,0))
  1. ...S DA=BJPCX
  1. ...D MEAS^AUPNMAP
  1. ..S BJPCX=0
  1. ..F S BJPCX=$O(^AUPNVXAM("AD",BJPCV,BJPCX)) Q:BJPCX'=+BJPCX D
  1. ...Q:'$D(^AUPNVXAM(BJPCX,0))
  1. ...S DA=BJPCX
  1. ...D EXAM^AUPNMAP
  1. Q
  1. FHAGE ;
  1. ;move age range to age
  1. D MES^XPDUTL($$CJ^XLFSTR("Moving Family History Age Range to Age field..",IOM))
  1. NEW BJPCX,BJPCA,BJPCV
  1. S BJPCX=0 F S BJPCX=$O(^AUPNFH(BJPCX)) Q:BJPCX'=+BJPCX D
  1. .Q:$P(^AUPNFH(BJPCX,0),U,16) ;already dealt with this entry
  1. .I $P(^AUPNFH(BJPCX,0),U,5)]"" D Q
  1. ..S DA=BJPCX,DIE="^AUPNFH(",DR=".11///@;.16///1" D ^DIE K DA,DIE,DR
  1. .Q:$P(^AUPNFH(BJPCX,0),U,11)="" ;no age range
  1. .S BJPCA=$P(^AUPNFH(BJPCX,0),U,11)
  1. .I BJPCA="U" D Q
  1. ..S DA=BJPCX,DIE="^AUPNFH(",DR=".11///@;.16///1" D ^DIE K DA,DIE,DR
  1. .S BJPCV=$S(BJPCA=2:20,BJPCA=3:30,BJPCA=4:40,BJPCA=5:50,BJPCA=6:60,BJPCA=1:10,BJPCA="I":1)
  1. .S DA=BJPCX,DIE="^AUPNFH(",DR=".15///1;.16///1;.05///"_BJPCV D ^DIE K DA,DIE,DR
  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