BQINIGH1 ;VNGT/HS/ALA - iCare Nightly Job continued ; 11 Jun 2008 11:22 AM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
MEAS ;EP - Check for new Measurement Types in File #9999999.07
NEW VFIEN,DSIEN,MSIEN,NAME,CODE,CHIEN,TEXT,BTAG,BQIXTYP,BIL,XCLLFH
S VFIEN=$O(^BQI(90506.3,"B","Measurement","")) Q:VFIEN=""
S DSIEN=$O(^BQI(90506.3,VFIEN,10,"B","Measurement","")) Q:DSIEN=""
NEW DA,DIK
S DA(2)=VFIEN,DA(1)=DSIEN,DA=0,DIK="^BQI(90506.3,"_DA(2)_",10,"_DA(1)_",5,"
F S DA=$O(^BQI(90506.3,VFIEN,10,DSIEN,5,DA)) Q:'DA D ^DIK
S MSIEN=0
F S MSIEN=$O(^AUTTMSR(MSIEN)) Q:'MSIEN D
. S NAME=$P(^AUTTMSR(MSIEN,0),U,2),CODE=$P(^AUTTMSR(MSIEN,0),U,1)
. S CHIEN=$O(^BQI(90506.3,VFIEN,10,DSIEN,5,"B",NAME,""))
. I CHIEN'="" Q
. NEW DA,DIC,X
. S DA(2)=VFIEN,DA(1)=DSIEN,X=NAME
. S DIC="^BQI(90506.3,"_DA(2)_",10,"_DA(1)_",5,",DIC(0)="L"
. K DO,DD D FILE^DICN
. S DA=+Y
. NEW IENS
. S IENS=$$IENS^DILF(.DA)
. S BQIUPD(90506.315,IENS,.02)=CODE,BQIUPD(90506.315,IENS,.03)="Y"
. S BQIUPD(90506.315,IENS,.04)="APCDTVAL"
. I $E(CODE,1,3)="ASQ"!($E(NAME,1,3)="ASQ")!($E(CODE,1,3)="BMI") S BQIUPD(90506.315,IENS,.05)=1
. D FILE^DIE("","BQIUPD","ERROR")
. ;
. S BQIXTYP="H"_CODE_"^AUPNVMS2"
. I $T(@BQIXTYP)'="" D
.. S BTAG="H"_CODE
.. F BI=1:1 S BIL=$T(@(BTAG)+BI^AUPNVMS2) Q:BIL=""!($P(BIL,";;",1)'=" ") S TEXT(BI)=$P(BIL,";;",2)
.. I $D(TEXT)>0 D WP^DIE(90506.315,IENS,1,"","TEXT","ERROR")
.. K TEXT,BI
;
DSPM ; EP - Find the official IHS provider categories
NEW DSN,ABBRV,CODE,NSOURCE,NCAT,NCLIN,HDR,TEXT
S CODE="BDP"
F S CODE=$O(^BQI(90506.1,"B",CODE)) Q:CODE=""!($E(CODE,1,3)'="BDP") D
. S IEN=""
. F S IEN=$O(^BQI(90506.1,"B",CODE,IEN)) Q:IEN="" D
.. S BQIUPD(90506.1,IEN_",",.1)=1
.. I $P(^BQI(90506.1,IEN,0),U,11)="" S BQIUPD(90506.1,IEN_",",.11)=DT
D FILE^DIE("","BQIUPD","ERROR")
S DSN=0
F S DSN=$O(^BDPTCAT(DSN)) Q:'DSN D
. ;I $P(^BDPTCAT(DSN,0),U,7)'=1 Q
. S ABBRV=$P(^BDPTCAT(DSN,0),U,2) I ABBRV="" Q
. S CODE="BDP"_ABBRV
. S NSOURCE="Patient",NCLIN="Specialty Providers",NCAT="Other Patient Data"
. S HDR="T00030"_CODE
. S TEXT=$P(^BDPTCAT(DSN,0),U,1)
. I TEXT="DESIGNATED PRIMARY PROVIDER" Q
. S TEXT=$$LOWER^VALM1(TEXT)
. I $P(TEXT," ",1)="Hiv" D
.. S TEXT="HIV "_$P(TEXT," ",2,99)
. I $P(TEXT," ",1)="Ob" D
.. S TEXT="OB "_$P(TEXT," ",2,99)
. NEW DA,X,DIC,DLAYGO
. S DIC="^BQI(90506.1,",DIC(0)="L",X=CODE
. S DA=$O(^BQI(90506.1,"B",CODE,""))
. I DA="" D Q:$G(ERROR)=1
.. K DO,DD D FILE^DICN
.. S DA=+Y I DA=-1 S ERROR=1
. S BQIUPD(90506.1,DA_",",.03)=TEXT
. S BQIUPD(90506.1,DA_",",.08)=HDR
. S BQIUPD(90506.1,DA_",",.15)=120
. S BQIUPD(90506.1,DA_",",.1)="@"
. S BQIUPD(90506.1,DA_",",.11)="@"
. D FILE^DIE("","BQIUPD","ERROR")
. ;
. S BQIUPD(90506.1,DA_",",3.01)=NSOURCE
. S BQIUPD(90506.1,DA_",",3.02)=NCLIN
. S BQIUPD(90506.1,DA_",",3.03)=NCAT
. S BQIUPD(90506.1,DA_",",3.04)="Optional"
. S BQIUPD(90506.1,DA_",",1)="S VAL=$P($$BPD^BQIULPT(DFN,STVW),U,2)"
. D FILE^DIE("E","BQIUPD","ERROR")
K BQIUPD
;
TMPL ; Set list for templates with |V | data objects
K ^XTMP("BQITEMPL")
S ^XTMP("BQITEMPL",0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Templates containing |V | data objects"
NEW TMPN,BLN
S TMPN=0
F S TMPN=$O(^TIU(8927,TMPN)) Q:'TMPN D
. S BLN=0
. F S BLN=$O(^TIU(8927,TMPN,2,BLN)) Q:'BLN D
.. I ^TIU(8927,TMPN,2,BLN,0)["|V " S ^XTMP("BQITEMPL",TMPN)=""
;
TRG ;Check for new Asthma Health Factor Triggers
NEW ASCIEN,ASIEN,TEXT,CODE,ORD,BQIAST
K BQIAST
S ASCIEN=$O(^AUTTHF("B","ASTHMA TRIGGERS",0))
I ASCIEN'="" D
. S ASIEN=""
. F S ASIEN=$O(^AUTTHF("AC",ASCIEN,ASIEN)) Q:ASIEN="" D
.. I ASIEN=ASCIEN Q
.. S TEXT=$P(^AUTTHF(ASIEN,0),U,1),CODE="AST_"_ASIEN
.. I TEXT["-" S TEXT=$$LOWER^VALM1($P(TEXT,"-",1))_"-"_$$LOWER^VALM1($P(TEXT,"-",2))
.. I TEXT'["-" S TEXT=$$LOWER^VALM1(TEXT)
.. S BQIAST(CODE)=TEXT
S CODE=""
F S CODE=$O(BQIAST(CODE)) Q:CODE="" D
. S HDR="T00030"_CODE,NSOURCE="Asthma",NCLIN="",NCAT=""
. NEW DA,X,DIC,DLAYGO
. S DIC="^BQI(90506.1,",DIC(0)="L",X=CODE
. S DA=$O(^BQI(90506.1,"B",CODE,""))
. I DA'="" Q
. I DA="" D Q:$G(ERROR)=1
.. K DO,DD D FILE^DICN
.. S DA=+Y I DA=-1 S ERROR=1
.. S ORD=$O(^BQI(90506.1,"AD","A",""),-1)+1
. S BQIUPD(90506.1,DA_",",.03)=TEXT
. S BQIUPD(90506.1,DA_",",.08)=HDR
. S BQIUPD(90506.1,DA_",",.15)=120
. D FILE^DIE("","BQIUPD","ERROR")
. ;
. S BQIUPD(90506.1,DA_",",3.01)=NSOURCE
. S BQIUPD(90506.1,DA_",",3.02)=NCLIN
. S BQIUPD(90506.1,DA_",",3.03)=NCAT
. S BQIUPD(90506.1,DA_",",3.04)="Optional"
. S BQIUPD(90506.1,DA_",",3.05)=ORD
. S BQIUPD(90506.1,DA_",",1)="S VAL=$$DSP^BQIRGASU(DFN,STVW)"
. S BQIUPD(90506.1,DA_",",5)="S HF=$P($P(^BQI(90506.1,STVW,0),U,1),""_"",2),VAL=$$HF^BQIDCUTL(DFN,HF),VISIT=$P(VAL,U,2),VAL=$$FMTE^BQIUL1($P(VAL,U,1))"
. D FILE^DIE("E","BQIUPD","ERROR")
. K BQIUPD
. S HELP(1)=TEXT_": Date of most recent Asthma Trigger (Health Factor)."
. D WP^DIE(90506.1,DA_",",4,"","HELP","ERROR")
. K HELP
;
;Set Flag To Track Whether External Tag Call Or Not
S XCLLFH=1
;
FHDX ;EP - Sep up list of Family History Allowed DX codes
;
NEW II,DATA,BQITMP,TXT
;
S II=0,DATA=$NA(^XTMP("BQIFHDX")) K @DATA
S @DATA@(II)=$$FMADD^XLFDT(DT,7)_U_DT_U_"List of Family History Allowed DX Codes"
;
F TXT="Z80*","Z81*","Z82*","Z83*","Z84*" D
. S INDEX="BA" K BQITMP
. D LST^ATXAPI(30,80,TXT,"","BQITMP")
. S LIEN=""
. F S LIEN=$O(BQITMP(LIEN)) Q:LIEN="" D
.. S DESC=$$ICD9^BQIUL3(LIEN,,4),INAC=$$INIC^BQITAXX5(80,LIEN)
.. S II=II+1,@DATA@(II)=BQITMP(LIEN)_U_DESC_U_INAC
;
K DATA,DSC,DUP,DX,FILE,IEN,II,SRT,TXT,Y
Q
;
COMM ;EP - Set up communities
NEW CNME,CIEN,CSTE,CNTY,STCOCOMM,CCNT,IEN,DA,FILE,DATA
NEW SCHK,SMULT,CCHK,CMULT,CSCMULT,CSTR,SGLOB
S FILE=9999999.05
S II=0,SGLOB=$NA(^XTMP("BQICOMMZ")),DATA=$NA(^XTMP("BQICOMM"))
K @SGLOB,@DATA
S @DATA@(II)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Community Table List plus count of patients"
S CIEN=0
F S CIEN=$O(^AUTTCOM(CIEN)) Q:'CIEN D
. S DA=CIEN,IEN=$$IENS^DILF(.DA)
. ; Exclude Inactive Communities
. I $P($G(^AUTTCOM(CIEN,88)),U,2)'="",$P($G(^(88)),U,2)'>DT Q
. S CNME=$$GET1^DIQ(FILE,IEN,.01,"I")
. S CNTY=$$GET1^DIQ(FILE,IEN,.02,"E")
. S CSTE=$$GET1^DIQ(FILE,IEN,.03,"E")
. S STCOCOMM=$$GET1^DIQ(FILE,IEN,.08,"E")
. I CNME=""!(CSTE="")!(CNTY="") Q
. ; Set data into a 'sort' global.
. S @SGLOB@(CNME,CSTE)=CIEN
. S @SGLOB@(CNME,CSTE,CNTY,CIEN)=STCOCOMM
. NEW CCIEN,CNT
. S CCIEN="",CNT=0
. F S CCIEN=$O(^AUPNPAT("AC",CNME,CCIEN)) Q:CCIEN="" D
.. ;Exclude patients with no active HRNs
.. I '$$HRN^BQIUL1(CCIEN) Q
.. I $P($G(^AUPNPAT(CCIEN,11)),U,17)=CIEN S CNT=CNT+1
. S @SGLOB@("ZZCOUNT",CIEN)=CNT
. Q
; Read through temporary TMP and create final TMP.
S (CNME,CSTE,CNTY,CIEN)=""
F S CNME=$O(@SGLOB@(CNME)) Q:CNME="" D
. S (SCHK,SMULT)=0
. F S CSTE=$O(@SGLOB@(CNME,CSTE)) Q:CSTE="" D
.. ; Check for more than one state with same community name and flag it.
.. I 'SCHK S SCHK=1 I $O(@SGLOB@(CNME,CSTE))'="" S SMULT=1
.. ; If only one state for this Comm, set ^TMP and return to loop.
.. I 'SMULT D Q
... S CIEN=@SGLOB@(CNME,CSTE)
... S II=II+1,@DATA@(II)=CIEN_"^"_CNME_"^"_$G(@SGLOB@("ZZCOUNT",CIEN))
... ; More than one state for Comm, now loop thru and check for multiple counties.
.. S (CCHK,CMULT)=0
.. F S CNTY=$O(@SGLOB@(CNME,CSTE,CNTY)) Q:CNTY="" D
... I 'CCHK S CCHK=1 I $O(@SGLOB@(CNME,CSTE,CNTY))'="" S CMULT=1
... ; Include county name with Comm and State only if more than 1 entry for Comm AND State.
... S CSTR=CNME_" ("_CSTE_$S(CMULT:" "_CNTY,1:"")_")"
... ; Double check to make sure there are no multiple occurrances of Comm, State, AND County.
... S CSCMULT=""
... S CIEN=$O(@SGLOB@(CNME,CSTE,CNTY,""))
... I CIEN S CIEN=$O(@SGLOB@(CNME,CSTE,CNTY,CIEN)) S:CIEN CSCMULT=1
... S CIEN=""
... F S CIEN=$O(@SGLOB@(CNME,CSTE,CNTY,CIEN)) Q:'CIEN D
.... S STCOCOMM=@SGLOB@(CNME,CSTE,CNTY,CIEN)
.... S II=II+1,@DATA@(II)=CIEN_U_$S(CSCMULT:$P(CSTR,")")_$S('CMULT:" "_CNTY,1:"")_" "_STCOCOMM_")",1:CSTR)_U_@SGLOB@("ZZCOUNT",CIEN)
K @SGLOB
Q
;
AST ; Update all patients with any care management data
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
;
I $G(DT)="" D DT^DICRW
; Set the NIGHTLY ASTHMA STARTED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.22)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.24)=1
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
NEW TAG,TGIEN,REG,SRIEN,SRC,RIEN,STAT,DFN,SRCIEN
S DFN=0
F S DFN=$O(^XTMP("BQINIGHT",DFN)) Q:'DFN D
. I $G(^BQIPAT(DFN,0))="" D NPT^BQITASK(DFN)
. K ^BQIPAT(DFN,60)
. ; If flag is set for nightly/weekly
. S SRIEN=""
. F S SRIEN=$O(^BQI(90506.5,"AD",1,SRIEN)) Q:SRIEN="" D
.. I $P($G(^BQI(90506.5,SRIEN,0)),"^",10)=1 Q
.. ;I $P($G(^BQI(90506.5,SRIEN,0)),"^",16)'=1 Q
.. S SOURCE=$P($G(^BQI(90506.5,SRIEN,0)),"^",1)
.. S SRC=$P($G(^BQI(90506.5,SRIEN,0)),U,2)
.. ; If patient is deceased, don't calculate
.. I $P($G(^DPT(DFN,.35)),U,1)'="" Q
.. ; If patient has no active HRNs, quit
.. I '$$HRN^BQIUL1(DFN) Q
.. ; If patient has no visit in past 3 years
.. I '$$VTHR^BQIUL1(DFN) Q
.. I SOURCE="Pediatric",$$AGE^BQIAGE(DFN,"")>21 Q
.. D PAT^BQIRGASP(DFN,SRC)
K BDMDMRG,BDMJOB,BDMBTH,CYR,CIEN,PGTHR,PGRF,BDMRBD,BDMADAT,BDMTYPE,BDMRED,BMDBDAT,BDMPD
;
; Set the NIGHTLY ASTHMA STOPPED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.23)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.24)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
Q
;
SRC(SOURCE) ; EP
S SRIEN=$O(^BQI(90506.5,"B",SOURCE,"")) I SRIEN="" Q
S SRC=$P(^BQI(90506.5,SRIEN,0),U,2)
Q
BQINIGH1 ;VNGT/HS/ALA - iCare Nightly Job continued ; 11 Jun 2008 11:22 AM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
MEAS ;EP - Check for new Measurement Types in File #9999999.07
+1 NEW VFIEN,DSIEN,MSIEN,NAME,CODE,CHIEN,TEXT,BTAG,BQIXTYP,BIL,XCLLFH
+2 SET VFIEN=$ORDER(^BQI(90506.3,"B","Measurement",""))
IF VFIEN=""
QUIT
+3 SET DSIEN=$ORDER(^BQI(90506.3,VFIEN,10,"B","Measurement",""))
IF DSIEN=""
QUIT
+4 NEW DA,DIK
+5 SET DA(2)=VFIEN
SET DA(1)=DSIEN
SET DA=0
SET DIK="^BQI(90506.3,"_DA(2)_",10,"_DA(1)_",5,"
+6 FOR
SET DA=$ORDER(^BQI(90506.3,VFIEN,10,DSIEN,5,DA))
IF 'DA
QUIT
DO ^DIK
+7 SET MSIEN=0
+8 FOR
SET MSIEN=$ORDER(^AUTTMSR(MSIEN))
IF 'MSIEN
QUIT
Begin DoDot:1
+9 SET NAME=$PIECE(^AUTTMSR(MSIEN,0),U,2)
SET CODE=$PIECE(^AUTTMSR(MSIEN,0),U,1)
+10 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,DSIEN,5,"B",NAME,""))
+11 IF CHIEN'=""
QUIT
+12 NEW DA,DIC,X
+13 SET DA(2)=VFIEN
SET DA(1)=DSIEN
SET X=NAME
+14 SET DIC="^BQI(90506.3,"_DA(2)_",10,"_DA(1)_",5,"
SET DIC(0)="L"
+15 KILL DO,DD
DO FILE^DICN
+16 SET DA=+Y
+17 NEW IENS
+18 SET IENS=$$IENS^DILF(.DA)
+19 SET BQIUPD(90506.315,IENS,.02)=CODE
SET BQIUPD(90506.315,IENS,.03)="Y"
+20 SET BQIUPD(90506.315,IENS,.04)="APCDTVAL"
+21 IF $EXTRACT(CODE,1,3)="ASQ"!($EXTRACT(NAME,1,3)="ASQ")!($EXTRACT(CODE,1,3)="BMI")
SET BQIUPD(90506.315,IENS,.05)=1
+22 DO FILE^DIE("","BQIUPD","ERROR")
+23 ;
+24 SET BQIXTYP="H"_CODE_"^AUPNVMS2"
+25 IF $TEXT(@BQIXTYP)'=""
Begin DoDot:2
+26 SET BTAG="H"_CODE
+27 FOR BI=1:1
SET BIL=$TEXT(@(BTAG)+BI^AUPNVMS2)
IF BIL=""!($PIECE(BIL,";;",1)'=" ")
QUIT
SET TEXT(BI)=$PIECE(BIL,";;",2)
+28 IF $DATA(TEXT)>0
DO WP^DIE(90506.315,IENS,1,"","TEXT","ERROR")
+29 KILL TEXT,BI
End DoDot:2
End DoDot:1
+30 ;
DSPM ; EP - Find the official IHS provider categories
+1 NEW DSN,ABBRV,CODE,NSOURCE,NCAT,NCLIN,HDR,TEXT
+2 SET CODE="BDP"
+3 FOR
SET CODE=$ORDER(^BQI(90506.1,"B",CODE))
IF CODE=""!($EXTRACT(CODE,1,3)'="BDP")
QUIT
Begin DoDot:1
+4 SET IEN=""
+5 FOR
SET IEN=$ORDER(^BQI(90506.1,"B",CODE,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+6 SET BQIUPD(90506.1,IEN_",",.1)=1
+7 IF $PIECE(^BQI(90506.1,IEN,0),U,11)=""
SET BQIUPD(90506.1,IEN_",",.11)=DT
End DoDot:2
End DoDot:1
+8 DO FILE^DIE("","BQIUPD","ERROR")
+9 SET DSN=0
+10 FOR
SET DSN=$ORDER(^BDPTCAT(DSN))
IF 'DSN
QUIT
Begin DoDot:1
+11 ;I $P(^BDPTCAT(DSN,0),U,7)'=1 Q
+12 SET ABBRV=$PIECE(^BDPTCAT(DSN,0),U,2)
IF ABBRV=""
QUIT
+13 SET CODE="BDP"_ABBRV
+14 SET NSOURCE="Patient"
SET NCLIN="Specialty Providers"
SET NCAT="Other Patient Data"
+15 SET HDR="T00030"_CODE
+16 SET TEXT=$PIECE(^BDPTCAT(DSN,0),U,1)
+17 IF TEXT="DESIGNATED PRIMARY PROVIDER"
QUIT
+18 SET TEXT=$$LOWER^VALM1(TEXT)
+19 IF $PIECE(TEXT," ",1)="Hiv"
Begin DoDot:2
+20 SET TEXT="HIV "_$PIECE(TEXT," ",2,99)
End DoDot:2
+21 IF $PIECE(TEXT," ",1)="Ob"
Begin DoDot:2
+22 SET TEXT="OB "_$PIECE(TEXT," ",2,99)
End DoDot:2
+23 NEW DA,X,DIC,DLAYGO
+24 SET DIC="^BQI(90506.1,"
SET DIC(0)="L"
SET X=CODE
+25 SET DA=$ORDER(^BQI(90506.1,"B",CODE,""))
+26 IF DA=""
Begin DoDot:2
+27 KILL DO,DD
DO FILE^DICN
+28 SET DA=+Y
IF DA=-1
SET ERROR=1
End DoDot:2
IF $GET(ERROR)=1
QUIT
+29 SET BQIUPD(90506.1,DA_",",.03)=TEXT
+30 SET BQIUPD(90506.1,DA_",",.08)=HDR
+31 SET BQIUPD(90506.1,DA_",",.15)=120
+32 SET BQIUPD(90506.1,DA_",",.1)="@"
+33 SET BQIUPD(90506.1,DA_",",.11)="@"
+34 DO FILE^DIE("","BQIUPD","ERROR")
+35 ;
+36 SET BQIUPD(90506.1,DA_",",3.01)=NSOURCE
+37 SET BQIUPD(90506.1,DA_",",3.02)=NCLIN
+38 SET BQIUPD(90506.1,DA_",",3.03)=NCAT
+39 SET BQIUPD(90506.1,DA_",",3.04)="Optional"
+40 SET BQIUPD(90506.1,DA_",",1)="S VAL=$P($$BPD^BQIULPT(DFN,STVW),U,2)"
+41 DO FILE^DIE("E","BQIUPD","ERROR")
End DoDot:1
+42 KILL BQIUPD
+43 ;
TMPL ; Set list for templates with |V | data objects
+1 KILL ^XTMP("BQITEMPL")
+2 SET ^XTMP("BQITEMPL",0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Templates containing |V | data objects"
+3 NEW TMPN,BLN
+4 SET TMPN=0
+5 FOR
SET TMPN=$ORDER(^TIU(8927,TMPN))
IF 'TMPN
QUIT
Begin DoDot:1
+6 SET BLN=0
+7 FOR
SET BLN=$ORDER(^TIU(8927,TMPN,2,BLN))
IF 'BLN
QUIT
Begin DoDot:2
+8 IF ^TIU(8927,TMPN,2,BLN,0)["|V "
SET ^XTMP("BQITEMPL",TMPN)=""
End DoDot:2
End DoDot:1
+9 ;
TRG ;Check for new Asthma Health Factor Triggers
+1 NEW ASCIEN,ASIEN,TEXT,CODE,ORD,BQIAST
+2 KILL BQIAST
+3 SET ASCIEN=$ORDER(^AUTTHF("B","ASTHMA TRIGGERS",0))
+4 IF ASCIEN'=""
Begin DoDot:1
+5 SET ASIEN=""
+6 FOR
SET ASIEN=$ORDER(^AUTTHF("AC",ASCIEN,ASIEN))
IF ASIEN=""
QUIT
Begin DoDot:2
+7 IF ASIEN=ASCIEN
QUIT
+8 SET TEXT=$PIECE(^AUTTHF(ASIEN,0),U,1)
SET CODE="AST_"_ASIEN
+9 IF TEXT["-"
SET TEXT=$$LOWER^VALM1($PIECE(TEXT,"-",1))_"-"_$$LOWER^VALM1($PIECE(TEXT,"-",2))
+10 IF TEXT'["-"
SET TEXT=$$LOWER^VALM1(TEXT)
+11 SET BQIAST(CODE)=TEXT
End DoDot:2
End DoDot:1
+12 SET CODE=""
+13 FOR
SET CODE=$ORDER(BQIAST(CODE))
IF CODE=""
QUIT
Begin DoDot:1
+14 SET HDR="T00030"_CODE
SET NSOURCE="Asthma"
SET NCLIN=""
SET NCAT=""
+15 NEW DA,X,DIC,DLAYGO
+16 SET DIC="^BQI(90506.1,"
SET DIC(0)="L"
SET X=CODE
+17 SET DA=$ORDER(^BQI(90506.1,"B",CODE,""))
+18 IF DA'=""
QUIT
+19 IF DA=""
Begin DoDot:2
+20 KILL DO,DD
DO FILE^DICN
+21 SET DA=+Y
IF DA=-1
SET ERROR=1
+22 SET ORD=$ORDER(^BQI(90506.1,"AD","A",""),-1)+1
End DoDot:2
IF $GET(ERROR)=1
QUIT
+23 SET BQIUPD(90506.1,DA_",",.03)=TEXT
+24 SET BQIUPD(90506.1,DA_",",.08)=HDR
+25 SET BQIUPD(90506.1,DA_",",.15)=120
+26 DO FILE^DIE("","BQIUPD","ERROR")
+27 ;
+28 SET BQIUPD(90506.1,DA_",",3.01)=NSOURCE
+29 SET BQIUPD(90506.1,DA_",",3.02)=NCLIN
+30 SET BQIUPD(90506.1,DA_",",3.03)=NCAT
+31 SET BQIUPD(90506.1,DA_",",3.04)="Optional"
+32 SET BQIUPD(90506.1,DA_",",3.05)=ORD
+33 SET BQIUPD(90506.1,DA_",",1)="S VAL=$$DSP^BQIRGASU(DFN,STVW)"
+34 SET BQIUPD(90506.1,DA_",",5)="S HF=$P($P(^BQI(90506.1,STVW,0),U,1),""_"",2),VAL=$$HF^BQIDCUTL(DFN,HF),VISIT=$P(VAL,U,2),VAL=$$FMTE^BQIUL1($P(VAL,U,1))"
+35 DO FILE^DIE("E","BQIUPD","ERROR")
+36 KILL BQIUPD
+37 SET HELP(1)=TEXT_": Date of most recent Asthma Trigger (Health Factor)."
+38 DO WP^DIE(90506.1,DA_",",4,"","HELP","ERROR")
+39 KILL HELP
End DoDot:1
+40 ;
+41 ;Set Flag To Track Whether External Tag Call Or Not
+42 SET XCLLFH=1
+43 ;
FHDX ;EP - Sep up list of Family History Allowed DX codes
+1 ;
+2 NEW II,DATA,BQITMP,TXT
+3 ;
+4 SET II=0
SET DATA=$NAME(^XTMP("BQIFHDX"))
KILL @DATA
+5 SET @DATA@(II)=$$FMADD^XLFDT(DT,7)_U_DT_U_"List of Family History Allowed DX Codes"
+6 ;
+7 FOR TXT="Z80*","Z81*","Z82*","Z83*","Z84*"
Begin DoDot:1
+8 SET INDEX="BA"
KILL BQITMP
+9 DO LST^ATXAPI(30,80,TXT,"","BQITMP")
+10 SET LIEN=""
+11 FOR
SET LIEN=$ORDER(BQITMP(LIEN))
IF LIEN=""
QUIT
Begin DoDot:2
+12 SET DESC=$$ICD9^BQIUL3(LIEN,,4)
SET INAC=$$INIC^BQITAXX5(80,LIEN)
+13 SET II=II+1
SET @DATA@(II)=BQITMP(LIEN)_U_DESC_U_INAC
End DoDot:2
End DoDot:1
+14 ;
+15 KILL DATA,DSC,DUP,DX,FILE,IEN,II,SRT,TXT,Y
+16 QUIT
+17 ;
COMM ;EP - Set up communities
+1 NEW CNME,CIEN,CSTE,CNTY,STCOCOMM,CCNT,IEN,DA,FILE,DATA
+2 NEW SCHK,SMULT,CCHK,CMULT,CSCMULT,CSTR,SGLOB
+3 SET FILE=9999999.05
+4 SET II=0
SET SGLOB=$NAME(^XTMP("BQICOMMZ"))
SET DATA=$NAME(^XTMP("BQICOMM"))
+5 KILL @SGLOB,@DATA
+6 SET @DATA@(II)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Community Table List plus count of patients"
+7 SET CIEN=0
+8 FOR
SET CIEN=$ORDER(^AUTTCOM(CIEN))
IF 'CIEN
QUIT
Begin DoDot:1
+9 SET DA=CIEN
SET IEN=$$IENS^DILF(.DA)
+10 ; Exclude Inactive Communities
+11 IF $PIECE($GET(^AUTTCOM(CIEN,88)),U,2)'=""
IF $PIECE($GET(^(88)),U,2)'>DT
QUIT
+12 SET CNME=$$GET1^DIQ(FILE,IEN,.01,"I")
+13 SET CNTY=$$GET1^DIQ(FILE,IEN,.02,"E")
+14 SET CSTE=$$GET1^DIQ(FILE,IEN,.03,"E")
+15 SET STCOCOMM=$$GET1^DIQ(FILE,IEN,.08,"E")
+16 IF CNME=""!(CSTE="")!(CNTY="")
QUIT
+17 ; Set data into a 'sort' global.
+18 SET @SGLOB@(CNME,CSTE)=CIEN
+19 SET @SGLOB@(CNME,CSTE,CNTY,CIEN)=STCOCOMM
+20 NEW CCIEN,CNT
+21 SET CCIEN=""
SET CNT=0
+22 FOR
SET CCIEN=$ORDER(^AUPNPAT("AC",CNME,CCIEN))
IF CCIEN=""
QUIT
Begin DoDot:2
+23 ;Exclude patients with no active HRNs
+24 IF '$$HRN^BQIUL1(CCIEN)
QUIT
+25 IF $PIECE($GET(^AUPNPAT(CCIEN,11)),U,17)=CIEN
SET CNT=CNT+1
End DoDot:2
+26 SET @SGLOB@("ZZCOUNT",CIEN)=CNT
+27 QUIT
End DoDot:1
+28 ; Read through temporary TMP and create final TMP.
+29 SET (CNME,CSTE,CNTY,CIEN)=""
+30 FOR
SET CNME=$ORDER(@SGLOB@(CNME))
IF CNME=""
QUIT
Begin DoDot:1
+31 SET (SCHK,SMULT)=0
+32 FOR
SET CSTE=$ORDER(@SGLOB@(CNME,CSTE))
IF CSTE=""
QUIT
Begin DoDot:2
+33 ; Check for more than one state with same community name and flag it.
+34 IF 'SCHK
SET SCHK=1
IF $ORDER(@SGLOB@(CNME,CSTE))'=""
SET SMULT=1
+35 ; If only one state for this Comm, set ^TMP and return to loop.
+36 IF 'SMULT
Begin DoDot:3
+37 SET CIEN=@SGLOB@(CNME,CSTE)
+38 SET II=II+1
SET @DATA@(II)=CIEN_"^"_CNME_"^"_$GET(@SGLOB@("ZZCOUNT",CIEN))
+39 ; More than one state for Comm, now loop thru and check for multiple counties.
End DoDot:3
QUIT
+40 SET (CCHK,CMULT)=0
+41 FOR
SET CNTY=$ORDER(@SGLOB@(CNME,CSTE,CNTY))
IF CNTY=""
QUIT
Begin DoDot:3
+42 IF 'CCHK
SET CCHK=1
IF $ORDER(@SGLOB@(CNME,CSTE,CNTY))'=""
SET CMULT=1
+43 ; Include county name with Comm and State only if more than 1 entry for Comm AND State.
+44 SET CSTR=CNME_" ("_CSTE_$SELECT(CMULT:" "_CNTY,1:"")_")"
+45 ; Double check to make sure there are no multiple occurrances of Comm, State, AND County.
+46 SET CSCMULT=""
+47 SET CIEN=$ORDER(@SGLOB@(CNME,CSTE,CNTY,""))
+48 IF CIEN
SET CIEN=$ORDER(@SGLOB@(CNME,CSTE,CNTY,CIEN))
IF CIEN
SET CSCMULT=1
+49 SET CIEN=""
+50 FOR
SET CIEN=$ORDER(@SGLOB@(CNME,CSTE,CNTY,CIEN))
IF 'CIEN
QUIT
Begin DoDot:4
+51 SET STCOCOMM=@SGLOB@(CNME,CSTE,CNTY,CIEN)
+52 SET II=II+1
SET @DATA@(II)=CIEN_U_$SELECT(CSCMULT:$PIECE(CSTR,")")_$SELECT('CMULT:" "_CNTY,1:"")_" "_STCOCOMM_")",1:CSTR)_U_@SGLOB@("ZZCOUNT",CIEN)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+53 KILL @SGLOB
+54 QUIT
+55 ;
AST ; Update all patients with any care management data
+1 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
+2 ;
+3 IF $GET(DT)=""
DO DT^DICRW
+4 ; Set the NIGHTLY ASTHMA STARTED field
+5 NEW DA
+6 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+7 SET BQIUPD(90508,DA_",",3.22)=$$NOW^XLFDT()
+8 SET BQIUPD(90508,DA_",",3.24)=1
+9 DO FILE^DIE("","BQIUPD","ERROR")
+10 KILL BQIUPD
+11 ;
+12 NEW TAG,TGIEN,REG,SRIEN,SRC,RIEN,STAT,DFN,SRCIEN
+13 SET DFN=0
+14 FOR
SET DFN=$ORDER(^XTMP("BQINIGHT",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+15 IF $GET(^BQIPAT(DFN,0))=""
DO NPT^BQITASK(DFN)
+16 KILL ^BQIPAT(DFN,60)
+17 ; If flag is set for nightly/weekly
+18 SET SRIEN=""
+19 FOR
SET SRIEN=$ORDER(^BQI(90506.5,"AD",1,SRIEN))
IF SRIEN=""
QUIT
Begin DoDot:2
+20 IF $PIECE($GET(^BQI(90506.5,SRIEN,0)),"^",10)=1
QUIT
+21 ;I $P($G(^BQI(90506.5,SRIEN,0)),"^",16)'=1 Q
+22 SET SOURCE=$PIECE($GET(^BQI(90506.5,SRIEN,0)),"^",1)
+23 SET SRC=$PIECE($GET(^BQI(90506.5,SRIEN,0)),U,2)
+24 ; If patient is deceased, don't calculate
+25 IF $PIECE($GET(^DPT(DFN,.35)),U,1)'=""
QUIT
+26 ; If patient has no active HRNs, quit
+27 IF '$$HRN^BQIUL1(DFN)
QUIT
+28 ; If patient has no visit in past 3 years
+29 IF '$$VTHR^BQIUL1(DFN)
QUIT
+30 IF SOURCE="Pediatric"
IF $$AGE^BQIAGE(DFN,"")>21
QUIT
+31 DO PAT^BQIRGASP(DFN,SRC)
End DoDot:2
End DoDot:1
+32 KILL BDMDMRG,BDMJOB,BDMBTH,CYR,CIEN,PGTHR,PGRF,BDMRBD,BDMADAT,BDMTYPE,BDMRED,BMDBDAT,BDMPD
+33 ;
+34 ; Set the NIGHTLY ASTHMA STOPPED field
+35 NEW DA
+36 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+37 SET BQIUPD(90508,DA_",",3.23)=$$NOW^XLFDT()
+38 SET BQIUPD(90508,DA_",",3.24)="@"
+39 DO FILE^DIE("","BQIUPD","ERROR")
+40 KILL BQIUPD
+41 QUIT
+42 ;
SRC(SOURCE) ; EP
+1 SET SRIEN=$ORDER(^BQI(90506.5,"B",SOURCE,""))
IF SRIEN=""
QUIT
+2 SET SRC=$PIECE(^BQI(90506.5,SRIEN,0),U,2)
+3 QUIT
