BQI11PST ;PRXM/HC/ALA-Version 1.1 Post-Install ; 30 May 2007 5:19 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
EN ;EP
;
; Set up the parameters file with the default location
NEW BGPHOME,BGPHN,BQIDA,FD,BGDATA,IDIN
S BGPHN=$O(^BGPSITE(0)) S:BGPHN BGPHOME=$P($G(^BGPSITE(BGPHN,0)),U,1)
Q:$G(BGPHOME)=""
S BQIDA=1
S BQIUPD(90508,BQIDA_",",.01)=BGPHOME
S BQIUPD(90508,BQIDA_",",1)=$G(^XTMP("BQICARE","VISIT"))
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
; Check for missing node zeros from NPT^BQITASK error
S BQIN=0
F S BQIN=$O(^BQIPAT(BQIN)) Q:'BQIN I $G(^BQIPAT(BQIN,0))="" S ^BQIPAT(BQIN,0)=BQIN,^BQIPAT("B",BQIN,BQIN)=""
;
; if iCare hasn't been installed before, set up initial information
I $G(^XTMP("BQICARE",0))=0 D
. ; Reset all date started/stopped values
. F FD=.02,.03,.04,.05,.06,.07,.15,.16,1.01,1.02,1.03,1.04,1.05,1.06,1.07,1.08 S BQIUPD(90508,BQIDA_",",FD)="@"
. D FILE^DIE("","BQIUPD","ERROR")
. ; Set the last visit IEN
. S BQIUPD(90508,BQIDA_",",1)=$O(^AUPNVSIT("A"),-1)
. D FILE^DIE("","BQIUPD","ERROR")
. K BQIUPD
. ; Set up the taxonomies
. D LTAX
. ; Set up the 'ALL REMINDERS' list
. D REM
. ; Set up initial program to populate BQIPAT
. S ZTDESC="ICARE TAG PROGRAM",ZTRTN="ENT^BQI1POJB",ZTIO=""
. S JBNOW=$$NOW^XLFDT()
. S JBDATE=$S($E($P(JBNOW,".",2),1,2)<20:DT,1:$$FMADD^XLFDT(DT,+1))
. S ZTDTH=JBDATE_".20"
. D ^%ZTLOAD
. NEW DA,IENS
. S DA=BQIDA,IENS=$$IENS^DILF(.DA)
. S BQIUPD(90508,IENS,.1)=ZTSK
. D FILE^DIE("","BQIUPD","ERROR")
;
K ZTDESC,ZTRTN,ZTIO,JBNOW,JBDATE,ZTDTH,ZTSK,BQIGDA,N,ERROR
K BQIINDG,^XTMP("BQICARE")
;
; For Version 1.1
D LTAX
; Add Taxonomy short descriptions
NEW TEXT,TAX,DESC,TIEN,BQIUPD,ERROR
F I=1:1 S TEXT=$P($T(TDSC+I),";;",1) Q:TEXT="" D
. S TAX=$P(TEXT,U,1),DESC=$P(TEXT,U,2)
. S TIEN=$$FIND1^DIC(9002226,"","B",TAX,"","","ERROR")
. S BQIUPD(9002226,TIEN_",",.02)=DESC
D FILE^DIE("","BQIUPD","ERROR")
;
; For existing sites
I $O(^BQICARE(0))'="" D
. D PDSC
. ; Check for new CRS version
. NEW BQIH,OBQIYR,NBQIYR
. S BQIH=$$SPM^BQIGPUTL()
. S OBQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")
. D GCHK^BQIGPUPD(1)
. S BQIH=$$SPM^BQIGPUTL()
. S NBQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")
. I OBQIYR=NBQIYR Q
. ; Set up TaskMan to reset GPRA data
. NEW ZTDESC,ZTRTN,ZTIO,JBNOW,ZTDTH,ZTSK
. S ZTDESC="ICARE RESET DATA",ZTRTN="FGP^BQI11PST",ZTIO=""
. S JBNOW=$$NOW^XLFDT()
. S ZTDTH=$$FMADD^XLFDT(JBNOW,,,3)
. D ^%ZTLOAD
;
;Set the version number
S DA=$O(^BQI(90508,0))
S BQIUPD(90508,DA_",",.08)="1.1.29"
S BQIUPD(90508,DA_",",.09)="1.1T29"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
; Update the reminders view entries
D UPV
;
; Set up to initialize reminders
S ZTDESC="ICARE REMINDERS CALCULATE",ZTRTN="EN^BQITASK1",ZTIO=""
S JBNOW=$$NOW^XLFDT()
S JBDATE=$S($E($P(JBNOW,".",2),1,2)<20:DT,1:$$FMADD^XLFDT(DT,+1))
S ZTDTH=JBDATE_".20"
D ^%ZTLOAD
K ZTDESC,ZTRTN,ZTIO,JBNOW,JBDATE,ZTDTH,ZTSK
;
; Check if patch 1 was installed, if not, need to kill CVD tags
; and recalculate
I '$$PATCH^XPDUTL("BQI*1.0*1") D
. NEW DA,DIK,DFN
. S DFN=0
. F S DFN=$O(^BQIPAT(DFN)) Q:'DFN D
.. S DA(1)=DFN,DA=6,DIK="^BQIPAT("_DA(1)_",20,"
.. D ^DIK
. ;
. ; Set up task to run to regenerate Dx Categories
. NEW ZTDESC,ZTRTN,ZTIO,JBNOW,JBDATE,ZTDTH,ZTSK
. S ZTDESC="ICARE DX CAT PROGRAM",ZTRTN="DXC^BQITASK2",ZTIO=""
. S JBNOW=$$NOW^XLFDT()
. S JBDATE=$S($E($P(JBNOW,".",2),1,2)<18:DT,1:$$FMADD^XLFDT(DT,+1))
. S ZTDTH=JBDATE_".18"
. D ^%ZTLOAD
. K ZTDESC,ZTRTN,ZTIO,JBNOW,JBDATE,ZTDTH,ZTSK
;
; Set up TaskMan jobs, if they haven't already been set up
D ^BQISCHED
;
ML ;EP - Check for bad pointers in Location file
NEW LOC,AREA,SU,CT,XMY,XMZ,XMFROM
K ^TMP("BQIMAIL",$J)
S LOC=0,CT=0
F S LOC=$O(^AUTTLOC(LOC)) Q:'LOC D
. I $P(^AUTTLOC(LOC,0),"^",21)'="" Q
. S AREA=$P(^AUTTLOC(LOC,0),"^",4)
. S SU=$P(^AUTTLOC(LOC,0),"^",5)
. I SU'="",$$GET1^DIQ(9999999.22,SU_",",.01,"E")="" D
.. S CT=CT+1,^TMP("BQIMAIL",$J,CT,0)="Location: "_$P(^DIC(4,LOC,0),U,1)_" has a bad Service Unit pointer."
. I AREA'="",$$GET1^DIQ(9999999.21,AREA_",",.01,"E")="" D
.. S CT=CT+1,^TMP("BQIMAIL",$J,CT,0)="Location: "_$P(^DIC(4,LOC,0),U,1)_" has a bad Area pointer."
;
I $D(^TMP("BQIMAIL",$J))>0 D
. S CT=CT+1,^TMP("BQIMAIL",$J,CT,0)=" "
. S XMSUB="iCare Install Problem",XMFROM="iCare Install"
. S XMTEXT="^TMP(""BQIMAIL"",$J,"
. I $G(DUZ)'="" S XMDUZ=DUZ,XMY(DUZ)=""
. I $G(DUZ)="" S XMDUZ="iCare Install"
. S XMY(DUZ)=""
. I '$D(XMY) S XMY(.5)=""
. D ^XMD
. K XMSUB,XMTEXT,XMY,XMDUZ,XMZ,XMFROM
Q
;
FGP ;EP - Fix the GPRA layouts in existing panels
NEW OWNR,PLIEN,LIEN,VAL,NVAL,SHR,DFN
S OWNR=0
F S OWNR=$O(^BQICARE(OWNR)) Q:'OWNR D
. S PLIEN=0
. F S PLIEN=$O(^BQICARE(OWNR,1,PLIEN)) Q:'PLIEN D
.. NEW DA,IENS,BQIYR,BQIH,BQIY
.. S DA(1)=OWNR,DA=PLIEN,IENS=$$IENS^DILF(.DA)
.. S BQIYR=$$GET1^DIQ(90505.01,IENS,3.3,"E")
.. S BQIH=$$SPM^BQIGPUTL()
.. I BQIYR="" S BQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")
.. S LIEN=0
.. F S LIEN=$O(^BQICARE(OWNR,1,PLIEN,25,LIEN)) Q:'LIEN D
... S VAL=$P(^BQICARE(OWNR,1,PLIEN,25,LIEN,0),U,1)
... I VAL'?.N Q
... S NVAL=BQIYR_"_"_VAL
... S DA(2)=OWNR,DA(1)=PLIEN,DA=LIEN,IENS=$$IENS^DILF(.DA)
... S BQIUPD(90505.125,IENS,.01)=NVAL
.. D FILE^DIE("","BQIUPD","ERROR")
.. K BQIUPD
.. ;
.. ; Fix existing GPRA layouts for Share users
.. S SHR=0
.. F S SHR=$O(^BQICARE(OWNR,1,PLIEN,30,SHR)) Q:'SHR D
... S LIEN=0
... F S LIEN=$O(^BQICARE(OWNR,1,PLIEN,30,SHR,25,LIEN)) Q:'LIEN D
.... S VAL=$P(^BQICARE(OWNR,1,PLIEN,30,SHR,25,LIEN,0),U,1)
.... I VAL'?.N Q
.... S NVAL=BQIYR_"_"_VAL
.... S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=SHR,DA=LIEN,IENS=$$IENS^DILF(.DA)
.... S BQIUPD(90505.325,IENS,.01)=NVAL
... D FILE^DIE("","BQIUPD","ERROR")
... K BQIUPD
;
; Fix patient's GPRA references
S DFN=0
F S DFN=$O(^BQIPAT(DFN)) Q:'DFN D
. S BQIYR=$P(^BQIPAT(DFN,0),U,2)
. I BQIYR="" D
.. S BQIH=$$SPM^BQIGPUTL()
.. S BQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")
. S IEN=0
. F S IEN=$O(^BQIPAT(DFN,30,IEN)) Q:'IEN D
.. S VAL=$P(^BQIPAT(DFN,30,IEN,0),U,1)
.. I VAL'?.N Q
.. S DA(1)=DFN,DA=IEN,IENS=$$IENS^DILF(.DA)
.. S BQIUPD(90507.53,IENS,.01)="@"
. D FILE^DIE("","BQIUPD","ERROR")
. K BQIUPD
;
Q
;
PDSC ;EP - Load revised generated descriptions for all panels
;
NEW OWNR,PLIEN
S OWNR=0
F S OWNR=$O(^BQICARE(OWNR)) Q:'OWNR D
. S PLIEN=0
. F S PLIEN=$O(^BQICARE(OWNR,1,PLIEN)) Q:'PLIEN D
.. NEW DA,IENS
.. S DA(1)=OWNR,DA=PLIEN,IENS=$$IENS^DILF(.DA)
.. K DESC
.. D PEN^BQIPLDSC(OWNR,PLIEN,.DESC)
.. D WP^DIE(90505.01,IENS,5,"","DESC")
.. K DESC,BMXSEC
Q
;
UPV ;EP - Update the pointers for reminder views
NEW IEN,NAME,CODE,HIEN,HTAG,BQIUPD,IMN,TAG,NCODE,INAME
S IEN=""
RM ; EP
S IEN=$O(^BQI(90506.1,"AC","R",IEN)) G EXT:IEN=""
S NAME=$P(^BQI(90506.1,IEN,0),"^",3)
S CODE=$P(^BQI(90506.1,IEN,0),"^",1)
S HIEN=$P(CODE,"_",2),HTAG=$P(CODE,"_",1)
;
; If it's an immunization
I HTAG="AUTTIMM" D IMM G RM
; If it's not an immunization
S IMN=$O(^APCHSURV("B",NAME,"")) I IMN="" G RM
S TAG=$P($P(^APCHSURV(IMN,0),"^",2),";",1)
I HIEN=IMN,HTAG=TAG D G RM
. I $P(^APCHSURV(IMN,0),"^",3)'=1 D INA
S NCODE=HTAG_"_"_IMN
S BQIUPD(90506.1,IEN_",",.01)=NCODE
I $P(^APCHSURV(IMN,0),"^",3)'=1 D INA
G RM
;
INA ;EP - Inactivate
S BQIUPD(90506.1,IEN_",",.1)=1
S BQIUPD(90506.1,IEN_",",.11)=DT
Q
;
EXT ;EP - Store updates
I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
;D CHK^BQIRMDR
Q
;
IMM ;EP - Fix Immunization Reminders
S INAME=$P($G(^AUTTIMM(HIEN,0)),"^",2)
I INAME=NAME Q
S IMN=$O(^AUTTIMM("AC",NAME,"")) Q:IMN=""
S NCODE=HTAG_"_"_IMN
S BQIUPD(90506.1,IEN_",",.01)=NCODE
I $G(BQIUPD(90506.1,IEN_",",.1))=1 K BQIUPD(90506.1,IEN_",",.1),BQIUPD(90506.1,IEN_",",.11)
Q
;
REM ;EP - Set up the 'ALL REMINDERS' Patient Health Summary Definition
I '$$FIND1^DIC(9001015,"","","ALL REMINDERS","B","","") D
. N X,Y,DA,DR,DIC,DLAYGO,CMPNDX,REMNDX
. ;
. ; Create top level for 'ALL REMINDERS' Hlth Summary
. S X="ALL REMINDERS",DIC(0)="LZ",DLAYGO=9001015,DIC="^APCHSCTL("
. K DO,DD D FILE^DICN
. ;
. ; Build Sort Order Sub-File
. N DIC,DA,DIE,DR,X,BQIUPD
. S DLAYGO=9001015.01
. S (DA(1),REMNDX)=+Y,DA=10,DIC(0)="LZ",DIC="^APCHSCTL("_DA(1)_",1,"
. K DO,DD D FILE^DICN
. ;
. ; Add Component IEN for Reminders (from 9001016) to Hlth Summary
. S CMPNDX=$$FIND1^DIC(9001016,"","","HEALTH MAINTENANCE REMINDERS","B","","")
. Q:'CMPNDX
. S DA(1)=REMNDX,DA=10,DIE=DIC
. S DR=".01///"_DA_";1////"_CMPNDX
. D ^DIE
. ;
. ; Build Health Summary nodes.
. N DIC,DA,NDX,NDX2,RMNDR,X,Y,DR
. S DA(1)=REMNDX,DLAYGO=9001015.06,DIC(0)="LZ"
. S DIC="^APCHSCTL("_DA(1)_",5,"
. K DO,DD D FILE^DICN
. S NDX=""
. F S NDX=$O(^APCHSURV("AC",NDX)) Q:NDX="" D
.. S RMNDR=""
.. F S RMNDR=$O(^APCHSURV("AC",NDX,RMNDR)) Q:RMNDR="" D
... I $$GET1^DIQ(9001018,RMNDR,.03,"I")'="D" D
.... S (DA,NDX2)=(NDX*100)+RMNDR,DIE=DIC
.... S DR=".01///"_NDX2_";1////"_RMNDR
.... D ^DIE
.... Q
;
LTAX ;EP - Add Lab Taxonomies to ^ATXLAB
NEW X,DIC,DLAYGO,DA,DR,DIE,Y,LTAX,D0,DINUM
S DIC="^ATXLAB(",DIC(0)="L",DLAYGO=9002228
; Loop through the Taxonomies
D LDLAB(.LTAX)
F BJ=1:1 Q:'$D(LTAX(BJ)) S X=LTAX(BJ) D
. I $D(^ATXLAB("B",X)) D STXPT(X,"L") Q ; Skip pre-existing Lab taxonomies
. D ^DIC S DA=+Y
. I DA<1 Q
. S BQTXUP(9002228,DA_",",.02)=$P(X," ",2,999)
. S BQTXUP(9002228,DA_",",.05)=DUZ
. S BQTXUP(9002228,DA_",",.06)=DT
. S BQTXUP(9002228,DA_",",.09)=60
. D FILE^DIE("I","BQTXUP")
. S BQTXUP(9002228,DA_",",.08)="B"
. D FILE^DIE("E","BQTXUP")
. D STXPT(X,"L")
;
K DA,BJ,BQTXUP,DIC,DLAYGO,DINUM,D0,DR,X,Y
;
TAX ;EP - Set up the taxonomies
;
D ^BQITX
D ^BQIATX
;
; Reset the variable pointer values for the taxonomies
S N=0
F S N=$O(^BQI(90508,BQIDA,10,N)) Q:'N D
. S X=$P(^BQI(90508,BQIDA,10,N,0),U,1)
. I $P(^BQI(90508,BQIDA,10,N,0),U,3)=5 D STXPT(X,"L") Q
. D STXPT(X,"N")
;
; Reindex the site parameter file
NEW DIK
S DIK="^BQI(90508," D IXALL^DIK
;
; Check taxonomies
NEW IEN,PRGM,X
S IEN=0
F S IEN=$O(^BQI(90508,BQIDA,10,IEN)) Q:'IEN D
. I $P(^BQI(90508,BQIDA,10,IEN,0),U,2)'="" Q
. I $P(^BQI(90508,BQIDA,10,IEN,0),U,3)=5 Q
. S PRGM=U_$P(^BQI(90508,BQIDA,10,IEN,0),U,6) I PRGM="^" Q
. D @PRGM
. S X=$P(^BQI(90508,BQIDA,10,IEN,0),U,1)
. D STXPT(X,"N")
;
JRN ; EP - Turn off journaling for BQIPAT
NEW %,DIR
S %=$$NOJOURN^ZIBGCHAR("BQIPAT")
I % D
. W !!,"Attempt to turn off journaling for global ^BQIPAT failed because "
. W !?5,$$ERR^ZIBGCHAR(%)
. W !,"Please notify the OIT Help Desk for assistance."
. S DIR(0)="E" D ^DIR
Q
;
STXPT(TXNM,TYP) ; EP - Set taxonomy pointer into Site Parameter file
;
;Input
; TXNM - Taxonomy name
; TYP - Taxonomy Type (L = LAB, N = Non Lab)
NEW IEN,SIEN,DA,IENS,BQUPD,VALUE,GLB
I TYP="L" D
. S IEN=$O(^ATXLAB("B",TXNM,"")),GLB="ATXLAB("
. I IEN="" S TYP="N"
I TYP="N" S IEN=$O(^ATXAX("B",TXNM,"")),GLB="ATXAX("
I IEN="" S VALUE="@"
I IEN'="" S VALUE=IEN_";"_GLB
S SIEN=$O(^BQI(90508,BQIDA,10,"B",TXNM,""))
S DA(1)=BQIDA,DA=SIEN,IENS=$$IENS^DILF(.DA)
S BQUPD(90508.03,IENS,.02)=VALUE
D FILE^DIE("","BQUPD","ERROR")
Q
;
LDLAB(ARRAY) ;EP - Load site-populated Lab tests
NEW I,TEXT
F I=1:1 S TEXT=$P($T(LAB+I),";;",2) Q:TEXT="" S ARRAY(I)=TEXT
Q
;
LAB ;EP;LAB TESTS (SITE-POPULATED)
;;BGP GPRA ESTIMATED GFR TAX
;;DM AUDIT CHOLESTEROL TAX
;;DM AUDIT CREATININE TAX
;;DM AUDIT HDL TAX
;;DM AUDIT LDL CHOLESTEROL TAX
;;DM AUDIT TRIGLYCERIDE TAX
;;DM AUDIT FASTING GLUCOSE TESTS
;;
;
TDSC ; Fix Taxonomy Descriptions
;;BQI KNOWN CVD-1 CPTS^1 only identifies Known CVD
;;BQI KNOWN CVD-MULT CPTS^Multiple identify Known CVD
;;BQI HYPERLIPIDEMIA DXS^Hyperlipidemia Dxs
;;BQI IHD DXS^Ischemic Heart Disease Dxs
;;BQI KNOWN CVD-1 DXS^1 only identifies Known CVD
;;BQI KNOWN CVD-MULT DXS^Multiple identify Known CVD
;;BQI KNOWN CVD-1 PROCEDURES^1 only identifies Known CVD
;;BQI KNOWN CVD-MULT PROCEDURES^Multiple identify Known CVD
;;BQI STATIN NDC^Statin med NDCs
;;BQI STATIN MEDS CLASS^Statin med Class Codes
;;
BQI11PST ;PRXM/HC/ALA-Version 1.1 Post-Install ; 30 May 2007 5:19 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
EN ;EP
+1 ;
+2 ; Set up the parameters file with the default location
+3 NEW BGPHOME,BGPHN,BQIDA,FD,BGDATA,IDIN
+4 SET BGPHN=$ORDER(^BGPSITE(0))
IF BGPHN
SET BGPHOME=$PIECE($GET(^BGPSITE(BGPHN,0)),U,1)
+5 IF $GET(BGPHOME)=""
QUIT
+6 SET BQIDA=1
+7 SET BQIUPD(90508,BQIDA_",",.01)=BGPHOME
+8 SET BQIUPD(90508,BQIDA_",",1)=$GET(^XTMP("BQICARE","VISIT"))
+9 DO FILE^DIE("","BQIUPD","ERROR")
+10 KILL BQIUPD
+11 ;
+12 ; Check for missing node zeros from NPT^BQITASK error
+13 SET BQIN=0
+14 FOR
SET BQIN=$ORDER(^BQIPAT(BQIN))
IF 'BQIN
QUIT
IF $GET(^BQIPAT(BQIN,0))=""
SET ^BQIPAT(BQIN,0)=BQIN
SET ^BQIPAT("B",BQIN,BQIN)=""
+15 ;
+16 ; if iCare hasn't been installed before, set up initial information
+17 IF $GET(^XTMP("BQICARE",0))=0
Begin DoDot:1
+18 ; Reset all date started/stopped values
+19 FOR FD=.02,.03,.04,.05,.06,.07,.15,.16,1.01,1.02,1.03,1.04,1.05,1.06,1.07,1.08
SET BQIUPD(90508,BQIDA_",",FD)="@"
+20 DO FILE^DIE("","BQIUPD","ERROR")
+21 ; Set the last visit IEN
+22 SET BQIUPD(90508,BQIDA_",",1)=$ORDER(^AUPNVSIT("A"),-1)
+23 DO FILE^DIE("","BQIUPD","ERROR")
+24 KILL BQIUPD
+25 ; Set up the taxonomies
+26 DO LTAX
+27 ; Set up the 'ALL REMINDERS' list
+28 DO REM
+29 ; Set up initial program to populate BQIPAT
+30 SET ZTDESC="ICARE TAG PROGRAM"
SET ZTRTN="ENT^BQI1POJB"
SET ZTIO=""
+31 SET JBNOW=$$NOW^XLFDT()
+32 SET JBDATE=$SELECT($EXTRACT($PIECE(JBNOW,".",2),1,2)<20:DT,1:$$FMADD^XLFDT(DT,+1))
+33 SET ZTDTH=JBDATE_".20"
+34 DO ^%ZTLOAD
+35 NEW DA,IENS
+36 SET DA=BQIDA
SET IENS=$$IENS^DILF(.DA)
+37 SET BQIUPD(90508,IENS,.1)=ZTSK
+38 DO FILE^DIE("","BQIUPD","ERROR")
End DoDot:1
+39 ;
+40 KILL ZTDESC,ZTRTN,ZTIO,JBNOW,JBDATE,ZTDTH,ZTSK,BQIGDA,N,ERROR
+41 KILL BQIINDG,^XTMP("BQICARE")
+42 ;
+43 ; For Version 1.1
+44 DO LTAX
+45 ; Add Taxonomy short descriptions
+46 NEW TEXT,TAX,DESC,TIEN,BQIUPD,ERROR
+47 FOR I=1:1
SET TEXT=$PIECE($TEXT(TDSC+I),";;",1)
IF TEXT=""
QUIT
Begin DoDot:1
+48 SET TAX=$PIECE(TEXT,U,1)
SET DESC=$PIECE(TEXT,U,2)
+49 SET TIEN=$$FIND1^DIC(9002226,"","B",TAX,"","","ERROR")
+50 SET BQIUPD(9002226,TIEN_",",.02)=DESC
End DoDot:1
+51 DO FILE^DIE("","BQIUPD","ERROR")
+52 ;
+53 ; For existing sites
+54 IF $ORDER(^BQICARE(0))'=""
Begin DoDot:1
+55 DO PDSC
+56 ; Check for new CRS version
+57 NEW BQIH,OBQIYR,NBQIYR
+58 SET BQIH=$$SPM^BQIGPUTL()
+59 SET OBQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")
+60 DO GCHK^BQIGPUPD(1)
+61 SET BQIH=$$SPM^BQIGPUTL()
+62 SET NBQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")
+63 IF OBQIYR=NBQIYR
QUIT
+64 ; Set up TaskMan to reset GPRA data
+65 NEW ZTDESC,ZTRTN,ZTIO,JBNOW,ZTDTH,ZTSK
+66 SET ZTDESC="ICARE RESET DATA"
SET ZTRTN="FGP^BQI11PST"
SET ZTIO=""
+67 SET JBNOW=$$NOW^XLFDT()
+68 SET ZTDTH=$$FMADD^XLFDT(JBNOW,,,3)
+69 DO ^%ZTLOAD
End DoDot:1
+70 ;
+71 ;Set the version number
+72 SET DA=$ORDER(^BQI(90508,0))
+73 SET BQIUPD(90508,DA_",",.08)="1.1.29"
+74 SET BQIUPD(90508,DA_",",.09)="1.1T29"
+75 DO FILE^DIE("","BQIUPD","ERROR")
+76 KILL BQIUPD
+77 ;
+78 ; Update the reminders view entries
+79 DO UPV
+80 ;
+81 ; Set up to initialize reminders
+82 SET ZTDESC="ICARE REMINDERS CALCULATE"
SET ZTRTN="EN^BQITASK1"
SET ZTIO=""
+83 SET JBNOW=$$NOW^XLFDT()
+84 SET JBDATE=$SELECT($EXTRACT($PIECE(JBNOW,".",2),1,2)<20:DT,1:$$FMADD^XLFDT(DT,+1))
+85 SET ZTDTH=JBDATE_".20"
+86 DO ^%ZTLOAD
+87 KILL ZTDESC,ZTRTN,ZTIO,JBNOW,JBDATE,ZTDTH,ZTSK
+88 ;
+89 ; Check if patch 1 was installed, if not, need to kill CVD tags
+90 ; and recalculate
+91 IF '$$PATCH^XPDUTL("BQI*1.0*1")
Begin DoDot:1
+92 NEW DA,DIK,DFN
+93 SET DFN=0
+94 FOR
SET DFN=$ORDER(^BQIPAT(DFN))
IF 'DFN
QUIT
Begin DoDot:2
+95 SET DA(1)=DFN
SET DA=6
SET DIK="^BQIPAT("_DA(1)_",20,"
+96 DO ^DIK
End DoDot:2
+97 ;
+98 ; Set up task to run to regenerate Dx Categories
+99 NEW ZTDESC,ZTRTN,ZTIO,JBNOW,JBDATE,ZTDTH,ZTSK
+100 SET ZTDESC="ICARE DX CAT PROGRAM"
SET ZTRTN="DXC^BQITASK2"
SET ZTIO=""
+101 SET JBNOW=$$NOW^XLFDT()
+102 SET JBDATE=$SELECT($EXTRACT($PIECE(JBNOW,".",2),1,2)<18:DT,1:$$FMADD^XLFDT(DT,+1))
+103 SET ZTDTH=JBDATE_".18"
+104 DO ^%ZTLOAD
+105 KILL ZTDESC,ZTRTN,ZTIO,JBNOW,JBDATE,ZTDTH,ZTSK
End DoDot:1
+106 ;
+107 ; Set up TaskMan jobs, if they haven't already been set up
+108 DO ^BQISCHED
+109 ;
ML ;EP - Check for bad pointers in Location file
+1 NEW LOC,AREA,SU,CT,XMY,XMZ,XMFROM
+2 KILL ^TMP("BQIMAIL",$JOB)
+3 SET LOC=0
SET CT=0
+4 FOR
SET LOC=$ORDER(^AUTTLOC(LOC))
IF 'LOC
QUIT
Begin DoDot:1
+5 IF $PIECE(^AUTTLOC(LOC,0),"^",21)'=""
QUIT
+6 SET AREA=$PIECE(^AUTTLOC(LOC,0),"^",4)
+7 SET SU=$PIECE(^AUTTLOC(LOC,0),"^",5)
+8 IF SU'=""
IF $$GET1^DIQ(9999999.22,SU_",",.01,"E")=""
Begin DoDot:2
+9 SET CT=CT+1
SET ^TMP("BQIMAIL",$JOB,CT,0)="Location: "_$PIECE(^DIC(4,LOC,0),U,1)_" has a bad Service Unit pointer."
End DoDot:2
+10 IF AREA'=""
IF $$GET1^DIQ(9999999.21,AREA_",",.01,"E")=""
Begin DoDot:2
+11 SET CT=CT+1
SET ^TMP("BQIMAIL",$JOB,CT,0)="Location: "_$PIECE(^DIC(4,LOC,0),U,1)_" has a bad Area pointer."
End DoDot:2
End DoDot:1
+12 ;
+13 IF $DATA(^TMP("BQIMAIL",$JOB))>0
Begin DoDot:1
+14 SET CT=CT+1
SET ^TMP("BQIMAIL",$JOB,CT,0)=" "
+15 SET XMSUB="iCare Install Problem"
SET XMFROM="iCare Install"
+16 SET XMTEXT="^TMP(""BQIMAIL"",$J,"
+17 IF $GET(DUZ)'=""
SET XMDUZ=DUZ
SET XMY(DUZ)=""
+18 IF $GET(DUZ)=""
SET XMDUZ="iCare Install"
+19 SET XMY(DUZ)=""
+20 IF '$DATA(XMY)
SET XMY(.5)=""
+21 DO ^XMD
+22 KILL XMSUB,XMTEXT,XMY,XMDUZ,XMZ,XMFROM
End DoDot:1
+23 QUIT
+24 ;
FGP ;EP - Fix the GPRA layouts in existing panels
+1 NEW OWNR,PLIEN,LIEN,VAL,NVAL,SHR,DFN
+2 SET OWNR=0
+3 FOR
SET OWNR=$ORDER(^BQICARE(OWNR))
IF 'OWNR
QUIT
Begin DoDot:1
+4 SET PLIEN=0
+5 FOR
SET PLIEN=$ORDER(^BQICARE(OWNR,1,PLIEN))
IF 'PLIEN
QUIT
Begin DoDot:2
+6 NEW DA,IENS,BQIYR,BQIH,BQIY
+7 SET DA(1)=OWNR
SET DA=PLIEN
SET IENS=$$IENS^DILF(.DA)
+8 SET BQIYR=$$GET1^DIQ(90505.01,IENS,3.3,"E")
+9 SET BQIH=$$SPM^BQIGPUTL()
+10 IF BQIYR=""
SET BQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")
+11 SET LIEN=0
+12 FOR
SET LIEN=$ORDER(^BQICARE(OWNR,1,PLIEN,25,LIEN))
IF 'LIEN
QUIT
Begin DoDot:3
+13 SET VAL=$PIECE(^BQICARE(OWNR,1,PLIEN,25,LIEN,0),U,1)
+14 IF VAL'?.N
QUIT
+15 SET NVAL=BQIYR_"_"_VAL
+16 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET DA=LIEN
SET IENS=$$IENS^DILF(.DA)
+17 SET BQIUPD(90505.125,IENS,.01)=NVAL
End DoDot:3
+18 DO FILE^DIE("","BQIUPD","ERROR")
+19 KILL BQIUPD
+20 ;
+21 ; Fix existing GPRA layouts for Share users
+22 SET SHR=0
+23 FOR
SET SHR=$ORDER(^BQICARE(OWNR,1,PLIEN,30,SHR))
IF 'SHR
QUIT
Begin DoDot:3
+24 SET LIEN=0
+25 FOR
SET LIEN=$ORDER(^BQICARE(OWNR,1,PLIEN,30,SHR,25,LIEN))
IF 'LIEN
QUIT
Begin DoDot:4
+26 SET VAL=$PIECE(^BQICARE(OWNR,1,PLIEN,30,SHR,25,LIEN,0),U,1)
+27 IF VAL'?.N
QUIT
+28 SET NVAL=BQIYR_"_"_VAL
+29 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=SHR
SET DA=LIEN
SET IENS=$$IENS^DILF(.DA)
+30 SET BQIUPD(90505.325,IENS,.01)=NVAL
End DoDot:4
+31 DO FILE^DIE("","BQIUPD","ERROR")
+32 KILL BQIUPD
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;
+34 ; Fix patient's GPRA references
+35 SET DFN=0
+36 FOR
SET DFN=$ORDER(^BQIPAT(DFN))
IF 'DFN
QUIT
Begin DoDot:1
+37 SET BQIYR=$PIECE(^BQIPAT(DFN,0),U,2)
+38 IF BQIYR=""
Begin DoDot:2
+39 SET BQIH=$$SPM^BQIGPUTL()
+40 SET BQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")
End DoDot:2
+41 SET IEN=0
+42 FOR
SET IEN=$ORDER(^BQIPAT(DFN,30,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+43 SET VAL=$PIECE(^BQIPAT(DFN,30,IEN,0),U,1)
+44 IF VAL'?.N
QUIT
+45 SET DA(1)=DFN
SET DA=IEN
SET IENS=$$IENS^DILF(.DA)
+46 SET BQIUPD(90507.53,IENS,.01)="@"
End DoDot:2
+47 DO FILE^DIE("","BQIUPD","ERROR")
+48 KILL BQIUPD
End DoDot:1
+49 ;
+50 QUIT
+51 ;
PDSC ;EP - Load revised generated descriptions for all panels
+1 ;
+2 NEW OWNR,PLIEN
+3 SET OWNR=0
+4 FOR
SET OWNR=$ORDER(^BQICARE(OWNR))
IF 'OWNR
QUIT
Begin DoDot:1
+5 SET PLIEN=0
+6 FOR
SET PLIEN=$ORDER(^BQICARE(OWNR,1,PLIEN))
IF 'PLIEN
QUIT
Begin DoDot:2
+7 NEW DA,IENS
+8 SET DA(1)=OWNR
SET DA=PLIEN
SET IENS=$$IENS^DILF(.DA)
+9 KILL DESC
+10 DO PEN^BQIPLDSC(OWNR,PLIEN,.DESC)
+11 DO WP^DIE(90505.01,IENS,5,"","DESC")
+12 KILL DESC,BMXSEC
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
UPV ;EP - Update the pointers for reminder views
+1 NEW IEN,NAME,CODE,HIEN,HTAG,BQIUPD,IMN,TAG,NCODE,INAME
+2 SET IEN=""
RM ; EP
+1 SET IEN=$ORDER(^BQI(90506.1,"AC","R",IEN))
IF IEN=""
GOTO EXT
+2 SET NAME=$PIECE(^BQI(90506.1,IEN,0),"^",3)
+3 SET CODE=$PIECE(^BQI(90506.1,IEN,0),"^",1)
+4 SET HIEN=$PIECE(CODE,"_",2)
SET HTAG=$PIECE(CODE,"_",1)
+5 ;
+6 ; If it's an immunization
+7 IF HTAG="AUTTIMM"
DO IMM
GOTO RM
+8 ; If it's not an immunization
+9 SET IMN=$ORDER(^APCHSURV("B",NAME,""))
IF IMN=""
GOTO RM
+10 SET TAG=$PIECE($PIECE(^APCHSURV(IMN,0),"^",2),";",1)
+11 IF HIEN=IMN
IF HTAG=TAG
Begin DoDot:1
+12 IF $PIECE(^APCHSURV(IMN,0),"^",3)'=1
DO INA
End DoDot:1
GOTO RM
+13 SET NCODE=HTAG_"_"_IMN
+14 SET BQIUPD(90506.1,IEN_",",.01)=NCODE
+15 IF $PIECE(^APCHSURV(IMN,0),"^",3)'=1
DO INA
+16 GOTO RM
+17 ;
INA ;EP - Inactivate
+1 SET BQIUPD(90506.1,IEN_",",.1)=1
+2 SET BQIUPD(90506.1,IEN_",",.11)=DT
+3 QUIT
+4 ;
EXT ;EP - Store updates
+1 IF $DATA(BQIUPD)
DO FILE^DIE("","BQIUPD","ERROR")
+2 ;D CHK^BQIRMDR
+3 QUIT
+4 ;
IMM ;EP - Fix Immunization Reminders
+1 SET INAME=$PIECE($GET(^AUTTIMM(HIEN,0)),"^",2)
+2 IF INAME=NAME
QUIT
+3 SET IMN=$ORDER(^AUTTIMM("AC",NAME,""))
IF IMN=""
QUIT
+4 SET NCODE=HTAG_"_"_IMN
+5 SET BQIUPD(90506.1,IEN_",",.01)=NCODE
+6 IF $GET(BQIUPD(90506.1,IEN_",",.1))=1
KILL BQIUPD(90506.1,IEN_",",.1),BQIUPD(90506.1,IEN_",",.11)
+7 QUIT
+8 ;
REM ;EP - Set up the 'ALL REMINDERS' Patient Health Summary Definition
+1 IF '$$FIND1^DIC(9001015,"","","ALL REMINDERS","B","","")
Begin DoDot:1
+2 NEW X,Y,DA,DR,DIC,DLAYGO,CMPNDX,REMNDX
+3 ;
+4 ; Create top level for 'ALL REMINDERS' Hlth Summary
+5 SET X="ALL REMINDERS"
SET DIC(0)="LZ"
SET DLAYGO=9001015
SET DIC="^APCHSCTL("
+6 KILL DO,DD
DO FILE^DICN
+7 ;
+8 ; Build Sort Order Sub-File
+9 NEW DIC,DA,DIE,DR,X,BQIUPD
+10 SET DLAYGO=9001015.01
+11 SET (DA(1),REMNDX)=+Y
SET DA=10
SET DIC(0)="LZ"
SET DIC="^APCHSCTL("_DA(1)_",1,"
+12 KILL DO,DD
DO FILE^DICN
+13 ;
+14 ; Add Component IEN for Reminders (from 9001016) to Hlth Summary
+15 SET CMPNDX=$$FIND1^DIC(9001016,"","","HEALTH MAINTENANCE REMINDERS","B","","")
+16 IF 'CMPNDX
QUIT
+17 SET DA(1)=REMNDX
SET DA=10
SET DIE=DIC
+18 SET DR=".01///"_DA_";1////"_CMPNDX
+19 DO ^DIE
+20 ;
+21 ; Build Health Summary nodes.
+22 NEW DIC,DA,NDX,NDX2,RMNDR,X,Y,DR
+23 SET DA(1)=REMNDX
SET DLAYGO=9001015.06
SET DIC(0)="LZ"
+24 SET DIC="^APCHSCTL("_DA(1)_",5,"
+25 KILL DO,DD
DO FILE^DICN
+26 SET NDX=""
+27 FOR
SET NDX=$ORDER(^APCHSURV("AC",NDX))
IF NDX=""
QUIT
Begin DoDot:2
+28 SET RMNDR=""
+29 FOR
SET RMNDR=$ORDER(^APCHSURV("AC",NDX,RMNDR))
IF RMNDR=""
QUIT
Begin DoDot:3
+30 IF $$GET1^DIQ(9001018,RMNDR,.03,"I")'="D"
Begin DoDot:4
+31 SET (DA,NDX2)=(NDX*100)+RMNDR
SET DIE=DIC
+32 SET DR=".01///"_NDX2_";1////"_RMNDR
+33 DO ^DIE
+34 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+35 ;
LTAX ;EP - Add Lab Taxonomies to ^ATXLAB
+1 NEW X,DIC,DLAYGO,DA,DR,DIE,Y,LTAX,D0,DINUM
+2 SET DIC="^ATXLAB("
SET DIC(0)="L"
SET DLAYGO=9002228
+3 ; Loop through the Taxonomies
+4 DO LDLAB(.LTAX)
+5 FOR BJ=1:1
IF '$DATA(LTAX(BJ))
QUIT
SET X=LTAX(BJ)
Begin DoDot:1
+6 ; Skip pre-existing Lab taxonomies
IF $DATA(^ATXLAB("B",X))
DO STXPT(X,"L")
QUIT
+7 DO ^DIC
SET DA=+Y
+8 IF DA<1
QUIT
+9 SET BQTXUP(9002228,DA_",",.02)=$PIECE(X," ",2,999)
+10 SET BQTXUP(9002228,DA_",",.05)=DUZ
+11 SET BQTXUP(9002228,DA_",",.06)=DT
+12 SET BQTXUP(9002228,DA_",",.09)=60
+13 DO FILE^DIE("I","BQTXUP")
+14 SET BQTXUP(9002228,DA_",",.08)="B"
+15 DO FILE^DIE("E","BQTXUP")
+16 DO STXPT(X,"L")
End DoDot:1
+17 ;
+18 KILL DA,BJ,BQTXUP,DIC,DLAYGO,DINUM,D0,DR,X,Y
+19 ;
TAX ;EP - Set up the taxonomies
+1 ;
+2 DO ^BQITX
+3 DO ^BQIATX
+4 ;
+5 ; Reset the variable pointer values for the taxonomies
+6 SET N=0
+7 FOR
SET N=$ORDER(^BQI(90508,BQIDA,10,N))
IF 'N
QUIT
Begin DoDot:1
+8 SET X=$PIECE(^BQI(90508,BQIDA,10,N,0),U,1)
+9 IF $PIECE(^BQI(90508,BQIDA,10,N,0),U,3)=5
DO STXPT(X,"L")
QUIT
+10 DO STXPT(X,"N")
End DoDot:1
+11 ;
+12 ; Reindex the site parameter file
+13 NEW DIK
+14 SET DIK="^BQI(90508,"
DO IXALL^DIK
+15 ;
+16 ; Check taxonomies
+17 NEW IEN,PRGM,X
+18 SET IEN=0
+19 FOR
SET IEN=$ORDER(^BQI(90508,BQIDA,10,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+20 IF $PIECE(^BQI(90508,BQIDA,10,IEN,0),U,2)'=""
QUIT
+21 IF $PIECE(^BQI(90508,BQIDA,10,IEN,0),U,3)=5
QUIT
+22 SET PRGM=U_$PIECE(^BQI(90508,BQIDA,10,IEN,0),U,6)
IF PRGM="^"
QUIT
+23 DO @PRGM
+24 SET X=$PIECE(^BQI(90508,BQIDA,10,IEN,0),U,1)
+25 DO STXPT(X,"N")
End DoDot:1
+26 ;
JRN ; EP - Turn off journaling for BQIPAT
+1 NEW %,DIR
+2 SET %=$$NOJOURN^ZIBGCHAR("BQIPAT")
+3 IF %
Begin DoDot:1
+4 WRITE !!,"Attempt to turn off journaling for global ^BQIPAT failed because "
+5 WRITE !?5,$$ERR^ZIBGCHAR(%)
+6 WRITE !,"Please notify the OIT Help Desk for assistance."
+7 SET DIR(0)="E"
DO ^DIR
End DoDot:1
+8 QUIT
+9 ;
STXPT(TXNM,TYP) ; EP - Set taxonomy pointer into Site Parameter file
+1 ;
+2 ;Input
+3 ; TXNM - Taxonomy name
+4 ; TYP - Taxonomy Type (L = LAB, N = Non Lab)
+5 NEW IEN,SIEN,DA,IENS,BQUPD,VALUE,GLB
+6 IF TYP="L"
Begin DoDot:1
+7 SET IEN=$ORDER(^ATXLAB("B",TXNM,""))
SET GLB="ATXLAB("
+8 IF IEN=""
SET TYP="N"
End DoDot:1
+9 IF TYP="N"
SET IEN=$ORDER(^ATXAX("B",TXNM,""))
SET GLB="ATXAX("
+10 IF IEN=""
SET VALUE="@"
+11 IF IEN'=""
SET VALUE=IEN_";"_GLB
+12 SET SIEN=$ORDER(^BQI(90508,BQIDA,10,"B",TXNM,""))
+13 SET DA(1)=BQIDA
SET DA=SIEN
SET IENS=$$IENS^DILF(.DA)
+14 SET BQUPD(90508.03,IENS,.02)=VALUE
+15 DO FILE^DIE("","BQUPD","ERROR")
+16 QUIT
+17 ;
LDLAB(ARRAY) ;EP - Load site-populated Lab tests
+1 NEW I,TEXT
+2 FOR I=1:1
SET TEXT=$PIECE($TEXT(LAB+I),";;",2)
IF TEXT=""
QUIT
SET ARRAY(I)=TEXT
+3 QUIT
+4 ;
LAB ;EP;LAB TESTS (SITE-POPULATED)
+1 ;;BGP GPRA ESTIMATED GFR TAX
+2 ;;DM AUDIT CHOLESTEROL TAX
+3 ;;DM AUDIT CREATININE TAX
+4 ;;DM AUDIT HDL TAX
+5 ;;DM AUDIT LDL CHOLESTEROL TAX
+6 ;;DM AUDIT TRIGLYCERIDE TAX
+7 ;;DM AUDIT FASTING GLUCOSE TESTS
+8 ;;
+9 ;
TDSC ; Fix Taxonomy Descriptions
+1 ;;BQI KNOWN CVD-1 CPTS^1 only identifies Known CVD
+2 ;;BQI KNOWN CVD-MULT CPTS^Multiple identify Known CVD
+3 ;;BQI HYPERLIPIDEMIA DXS^Hyperlipidemia Dxs
+4 ;;BQI IHD DXS^Ischemic Heart Disease Dxs
+5 ;;BQI KNOWN CVD-1 DXS^1 only identifies Known CVD
+6 ;;BQI KNOWN CVD-MULT DXS^Multiple identify Known CVD
+7 ;;BQI KNOWN CVD-1 PROCEDURES^1 only identifies Known CVD
+8 ;;BQI KNOWN CVD-MULT PROCEDURES^Multiple identify Known CVD
+9 ;;BQI STATIN NDC^Statin med NDCs
+10 ;;BQI STATIN MEDS CLASS^Statin med Class Codes
+11 ;;
