BQIRMDR ;PRXM/HC/ALA-Find all reminder values ; 15 Mar 2007 2:30 PM
;;2.5;ICARE MANAGEMENT SYSTEM;;May 24, 2016;Build 27
;
PAT(DFN,REF) ;EP
NEW APCHSPAT,APCHSAGE,APCHSEX,APCHSANY,APCHSITM,APCHNON,APCHSURX
NEW ZAPCHS,APCHSCVD,APCHSITI,APCHLBE,APCHLCOL,APCHOVR,APCHSBP
NEW AMQQTAXN,APCHBHD,AMQQTAXN,APCHBHD,APCHC,APCHIMMC,APCHLADX
NEW APCHLED,APCHLEX,APCHLEXB,APCHLHF,APCHLPV,APCHLSIG,APCHNEXT
NEW APCHSBRK,APCHSBWR,APCHSC,APCHSCAT,APCHSCKP,APCHSCRI,APCHSDAT
NEW APCHSDF,APCHSDF1,APCHSDIS,APCHSINT,APCHSIVD,APCHSKD,APCHSMSC
NEW APCHSDO,APCHSDOB,APCHSDT,APCHSDUE,APCHSEXD,APCHSEXN,APCHSFLX
NEW APCHSKDT,APCHSKN,APCHSKND,APCHSLAB,APCHSLBD,APCHSLDT,APCHSLP
NEW APCHSMAM,APCHSMDT,APCHSYRY,APCHT,APCHTAXN,RIEN,DIC,DAYS,CODE
NEW APCHSMSD,APCHSNPG,APCHSOLD,APCHSQIT,APCHSTEX,APCHSURD,APCHSWD
NEW APCHTEST,APCHX,APCLAST,RMHDR,APCHNME,IMM,IMN,OT,OTH,REMTEXT,RJ
NEW VER,NAME,APCHA,APCHCOLW,APCHDX4,APCHHR,APCHIC,APCHLR,APCHLSTR
NEW APCHWHI,APCHWHL,APCHWHN,IQFL,IMOK,APCHRVAL,APCHSWHR,APCHR
NEW APCHNUMD,APCHLAST
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRMDR D UNWIND^%ZTER"
;
; Sometimes if Postmaster is the Task owner, DUZ is not defined correctly for some reminders
I $G(DUZ(2))=""!(DUZ=.5) M DUZ=^XTMP("BQIRMDR","DUZ")
;
S IMOK=0 I $$PATCH^XPDUTL("BI*8.3*1") S IMOK=1
; Delete any previous reminders
NEW DA,DIK
S DA(1)=DFN,DA=0,DIK="^BQIPAT("_DA(1)_",40,"
F S DA=$O(^BQIPAT(DFN,40,DA)) Q:'DA D ^DIK
;
; If deceased, don't include
;I $P($G(^DPT(DFN,.35)),U,1)'="" Q
; If no active HRN, don't include
;I '$$HRN^BQIUL1(DFN) Q
; If no visit in last 3 years, quit
;I '$$VTHR^BQIUL1(DFN) Q
;
S REF=$G(REF,0)
;
S APCHSPAT=DFN
S APCHSDOB=$P($G(^DPT(APCHSPAT,0)),U,3) I APCHSDOB="" Q
S APCHSAGE=$$AGE^BQIAGE(APCHSPAT)
S APCHSEX=$P(^DPT(APCHSPAT,0),U,2)
S APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
S (APCHSANY,APCHSITM)=0,APCHNON=1,APCHSURX=""
S APCHSCKP="S APCHSQIT=1 Q"
S APCHSBRK="Q"
S APCHSNPG=0
K APCHSTEX
;
; If patient not in BQIPAT yet, add them
I $G(^BQIPAT(DFN,0))="" D
. NEW DIC,X,DINUM,DLAYGO
. S (X,DINUM)=DFN,DLAYGO=90507.5,DIC="^BQIPAT(",DIC(0)="L"
. K DO,DD D FILE^DICN
;
S RIEN=""
F S RIEN=$O(^BQI(90506.1,"AC","R",RIEN)) Q:RIEN="" D
. I $P(^BQI(90506.1,RIEN,0),U,10)=1 Q
. S NAME=$P(^BQI(90506.1,RIEN,0),U,3)
. S CODE=$P(^BQI(90506.1,RIEN,0),U,1)
. S HIEN=$P(CODE,"_",2)
. ;
. I $P(CODE,"_",1)="REG" D REG^BQIRMDR1(DFN,CODE) Q
. ;
. I $P(CODE,"_",1)="EHR" D EMR^BQIRMDR1(DFN,CODE) Q
. ;
. I $P(CODE,"_",1)="CMET" D CMT^BQIRMDR1(DFN,CODE) Q
. ;
. I $P(CODE,"_",1)="AUTTIMM" D
.. S NAME="IMMUNIZATIONS"
.. S HIEN=$$FIND1^DIC(9001018,"","Q",NAME,"B","","ERROR")
. ;
. I $P(CODE,"_",1)="COLO" D
.. S NAME="COLORECTAL CA-SCOPE/XRAY"
.. S HIEN=$$FIND1^DIC(9001018,"","Q",NAME,"B","","ERROR")
. ;
. D RMR(DFN,HIEN)
;
; Fill in all missing immunizations
S IEN=""
F S IEN=$O(^BQI(90506.1,"AC","R",IEN)) Q:IEN="" D
. I $P(^BQI(90506.1,IEN,0),U,10)=1 Q
. S CODE=$P(^BQI(90506.1,IEN,0),U,1)
. I CODE["AUTTIMM" Q
. I $O(^BQIPAT(DFN,40,"B",CODE,""))'="" Q
. I $E(CODE,1,3)="REG" Q
. I $E(CODE,1,4)="CMET" Q
. S (REMDUE,REMLAST,REMNEXT)=""
. D FIL
;
D IZ^BQIRMDR2(DFN)
Q
;
RMR(DFN,HIEN) ;EP
NEW RCIEN,RCFILE,VISIT,APCHSPAT,APCHSDOB,APCHSAGE,APCHSCVD,APCHSCKP,RCFILE
NEW APCHSBRK,APCHSNPG,APCHSANY,APCHSITM,APCHNON,APCHSURX,IMNIEN,REMDUE
NEW REMLAST,REMNEXT
S APCHSPAT=DFN
S APCHSDOB=$P($G(^DPT(APCHSPAT,0)),U,3) I APCHSDOB="" Q
S APCHSAGE=$$AGE^BQIAGE(APCHSPAT)
S APCHSEX=$P(^DPT(APCHSPAT,0),U,2)
S APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
S (APCHSANY,APCHSITM)=0,APCHNON=1,APCHSURX=""
S APCHSCKP="S APCHSQIT=1 Q"
S APCHSBRK="Q"
S APCHSNPG=0
K APCHSTEX
S APCHNME=$P($G(^APCHSURV(HIEN,0)),U,1) I APCHNME="" Q
; Sometimes if Postmaster is the Task owner, DUZ is not defined correctly for some reminders
I $G(DUZ(2))="" M DUZ=^XTMP("BQIRMDR","DUZ")
S IQFL=0
I $G(IMOK)="" S IMOK=0 I $$PATCH^XPDUTL("BI*8.3*1") S IMOK=1
I APCHNME="IMMUNIZATIONS" D Q:IQFL
. I '$G(REF),'IMOK S IQFL=1 Q
S X=$$GVHMR^APCHSMU(DFN,HIEN)
I APCHNME="IMMUNIZATIONS" D Q
. I X["Immunization Forecasting disabled" Q
. I +$P(^BQI(90508,1,0),U,15)=0 Q
. NEW VALUE,IMM
. S IMM=X,VALUE=""
. F PC=4:1:$L(IMM,"^") S IMN=$P(IMM,U,PC) Q:IMN=""!(IMN[$C(31)) D
.. S REMNME=$P(IMN,"|",1),REMTEXT=$P(IMN,"|",2)
.. ; Need to strip off leading spaces
.. F RJ=1:1 Q:$E(REMNME,RJ,RJ)'=" "
.. S REMNME=$E(REMNME,RJ,$L(REMNME))
.. S IMNIEN=$O(^AUTTIMM("D",REMNME,"")) I IMNIEN="" Q
.. I IMOK D
... S VALUE=$$IMM^BQIREM(DFN,IMNIEN)
... S REMDUE=$P(VALUE,U,1),REMNEXT=$P(VALUE,U,2),REMLAST=$P(VALUE,U,3),VISIT=$P(VALUE,U,4),RCIEN=$P(VALUE,U,5)
... I VISIT'="" S RCFILE=9000010.11
.. I 'IMOK D
... S X=REMNME_U_U_$$IMM^BQIREM(DFN,IMNIEN)
... D PRS(X,HIEN)
.. I REMTEXT'="",REMNEXT'="" S REMNEXT=REMTEXT_" ("_REMNEXT_")"
.. I REMTEXT'="",REMNEXT="" S REMNEXT=REMTEXT
.. S CODE="AUTTIMM_"_IMNIEN
.. D FIL
I APCHNME="COLORECTAL CA-SCOPE/XRAY" D Q
. I X["|" D Q
.. K OTH,OT,BQINEXT,BQIDUE,BQILAST
.. S OTH=X
.. F PC=1:1:$L(OTH,"|") S OT=$P(OTH,"|",PC) Q:OT="" D
... D PRS(OT,HIEN)
... I REMNEXT'="" S BQINEXT(REMNEXT)=""
... I REMDUE'="" S BQIDUE(REMDUE)=""
... I REMLAST'="" S BQILAST(REMLAST)=""
.. S REMNEXT=$O(BQINEXT(""),-1)
.. S REMDUE=$O(BQIDUE(""),-1)
.. S REMLAST=$O(BQILAST(""),-1)
.. D FIL
. I $P(X,U,2)="" D PRS(X,HIEN),FIL Q
. I $P(X,U,2)'="" D
.. S OTH=$P(X,U,4),OT=$P(X,U,1)_U_$P(X,U,2)_U_$P(OTH," ",2)_U_$$DATE^BQIUL1($P(OTH," ",2))
.. D PRS(OT,HIEN)
.. D FIL
. D PRS(X,HIEN)
. D FIL
. Q
D PRS(X,HIEN)
D FIL
Q
;
PRS(VAL,HIEN) ;EP - Parse
S REMNME=$P(VAL,U,1)
I X="" S REMNME=$P(^APCHSURV(HIEN,0),U,1)
S REMDUE="",REMLAST=""
S REMLAST=$P(VAL,U,2),REMNEXT=$P(VAL,U,4),REMDUE=$P(VAL,U,5)
S VISIT=$P(VAL,U,6),RCIEN=$P(VAL,U,7),RCFILE=$P(VAL,U,8)
I REMNEXT["/",$E(REMNEXT,1,1)'?.N D
. I $E(REMNEXT,1,14)="MAY BE DUE NOW" Q
. I REMNEXT["per Women's Health system" D
.. NEW BQS,BQ,BQT,BQRDATE
.. S BQS=$F(REMNEXT,"(by"),BQRDATE=""
.. F BQ=BQS+1:1 S BQT=$E(REMNEXT,BQ,BQ) Q:BQT=")" S BQRDATE=BQRDATE_BQT
.. I $L(BQRDATE,"/")=2 S BQRDATE=$P(BQRDATE,"/",1)_"/01/"_$P(BQRDATE,"/",2)
.. S REMDUE=BQRDATE
. I APCHNME="COLORECTAL CA-SCOPE/XRAY" D
.. NEW XREMNXT,REMNME
.. S XREMNXT=$TR(REMNEXT," ",":")
.. S REMNEXT=$P(XREMNXT,":",$L(XREMNXT,":"))
.. S REMNME=$P(XREMNXT,":",1)
.. ;
I REMNEXT?2N1"/"2N1"/"2N S REMDUE=REMNEXT
I REMNEXT["MAY BE DUE NOW" S REMDUE=""
I REMNEXT["WAS DUE" S REMDUE=$P($P(REMNEXT,"WAS DUE ",2),")")
;
Q
;
FIL ;EP - File the reminder
NEW DIC,X,DINUM,DLAYGO,DA,IENS,BQIUPD
S X=CODE,DLAYGO=90507.54,DA(1)=DFN,DIC("P")=DLAYGO
I $G(^BQIPAT(DA(1),40,0))="" S ^BQIPAT(DA(1),40,0)="^90507.54P^^"
S DIC="^BQIPAT("_DA(1)_",40,",DIC(0)="L"
;K DO,DD D FILE^DICN
D ^DIC
S DA=+Y I DA=-1 Q
I REMDUE["." S REMDUE=REMDUE\1
I REMLAST["." S REMLAST=REMLAST\1
S IENS=$$IENS^DILF(.DA)
I $E(REMDUE,4,7)="0000" S REMDUE=$E(REMDUE,1,3)_"0101"
S BQIUPD(90507.54,IENS,.02)=$$DATE^BQIUL1(REMLAST)
S BQIUPD(90507.54,IENS,.03)=$G(REMNEXT)
S BQIUPD(90507.54,IENS,.04)=$$DATE^BQIUL1(REMDUE)
S BQIUPD(90507.54,IENS,.05)=$$NOW^XLFDT()
S BQIUPD(90507.5,DFN_",",.08)=$$NOW^XLFDT()
I $$VFIELD^DILFD(90507.54,.06) S BQIUPD(90507.54,IENS,.06)=$G(VISIT)
I $$VFIELD^DILFD(90507.54,.07) S BQIUPD(90507.54,IENS,.07)=$G(RCIEN)
I $$VFIELD^DILFD(90507.54,.08) S BQIUPD(90507.54,IENS,.08)=$G(RCFILE)
D FILE^DIE("","BQIUPD","ERROR")
;
;Check reminder notification is completed
D COMP^BQINOTR(DFN,CODE)
Q
;
CHK(TJOB) ;EP - Check for reminders and add new ones if found and inactivate
; ones no longer in list
; Input
; TJOB - Type of job
;
S REF=0
; Delete reminders in 'All Reminders'
NEW DIC,DIE,DA,NDX,NDX2,RMNDR,X,Y,DR,REMNDX,CALL,TAG
S REMNDX=$$FIND1^DIC(9001015,"","","ALL REMINDERS","B","","")
; Kill Health Summary nodes
S DA(1)=REMNDX,DA=0,DIK="^APCHSCTL("_DA(1)_",5,"
F S DA=$O(^APCHSCTL(REMNDX,5,DA)) Q:'DA D ^DIK
;
; Add reminders back to 'All Reminders'
S DA(1)=REMNDX,DLAYGO=9001015.06,DIC(0)="LZ"
S DIC="^APCHSCTL("_DA(1)_",5,"
;
S RMNDR=0
F S RMNDR=$O(^APCHSURV(RMNDR)) Q:'RMNDR D
. I $$GET1^DIQ(9001018,RMNDR,.03,"I")=1 D
.. ; if not an official IHS reminder, quit
.. I $$GET1^DIQ(9001018,RMNDR,.06,"I")'=1 Q
.. ; if it is a treatment prompt instead, quit
.. I $$GET1^DIQ(9001018,RMNDR,.07,"I")="T" Q
.. S NDX=+$P(^APCHSURV(RMNDR,0),U,5)
.. S (DA,NDX2)=(NDX*100)+RMNDR
.. S X=NDX2
.. K DO,DD D FILE^DICN
.. S DA=+Y,DIE=DIC
.. S DR="1////"_RMNDR
.. D ^DIE
.. Q
;
; Inactive all reminders
K BQIUPD
NEW SRCE,QFL
S IEN=""
F S IEN=$O(^BQI(90506.1,"AC","R",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")
K BQIUPD
;
FND ; Find the reminders and either reactivate or create new entry
NEW BQIRM,SOURCE,DEF,ERROR,GCAT,RCAT,RCLIN,GCLIN,HDR,QFL,TEXT
S BQIRM=$$FIND1^DIC(9001015,"","","ALL REMINDERS","B","","")
S IEN=0,SOURCE="Reminders",GCAT="",GCLIN=""
F S IEN=$O(^APCHSCTL(BQIRM,5,IEN)) Q:'IEN D
. S HIEN=$P(^APCHSCTL(BQIRM,5,IEN,0),U,2)
. I $P($G(^APCHSURV(HIEN,0)),U,3)'=1 Q
. I $P($G(^APCHSURV(HIEN,0)),U,7)="T" Q
. S TEXT=$P(^APCHSURV(HIEN,0),U,1),DEF=$P(^APCHSURV(HIEN,0),U,6)
. S CALL=$P(^APCHSURV(HIEN,0),U,2),TAG=$P(CALL,";",1)
. I TAG="" Q
. S RCAT="Health Summary",RCLIN=$$GET1^DIQ(9001018,HIEN_",",.05,"E")
. S:RCLIN="" RCLIN="No Category"
. ; if reminder is an official IHS reminder with a category of GENERAL
. ; make it a default
. S DEF=$S(DEF=1&(RCLIN="GENERAL"):1,1:0)
. I TEXT="IMMUNIZATIONS" D Q
.. I $G(IMOK)="" S IMOK=0 I $$PATCH^XPDUTL("BI*8.3*1") S IMOK=1
.. I +$P(^BQI(90508,1,0),U,15)=0 Q
.. NEW IIEN
.. S IIEN=0
.. F S IIEN=$O(^AUTTIMM(IIEN)) Q:'IIEN D
... ; If inactive, quit
... I $P(^AUTTIMM(IIEN,0),U,7)=1 Q
... S TEXT=$P(^AUTTIMM(IIEN,0),U,2)
... S CODE="AUTTIMM_"_IIEN,RCLIN="IZ Forecast"
... S HDR="T00050"_CODE
... S RIEN="",RIEN=$O(^BQI(90506.1,"B",CODE,RIEN))
... I RIEN'="" D REA^BQIRMDR1 Q
... D FILE
. ;
. ; If IMMUNIZATION category and disabled, quit
. I $$GET1^DIQ(9001018,HIEN_",",.05,"E")["IMMUNIZATION",+$P(^BQI(90508,1,0),U,18)=0 Q
. S CODE=TAG_"_"_HIEN
. S HDR="T00050"_CODE
. S RIEN="",RIEN=$O(^BQI(90506.1,"B",CODE,RIEN))
. I RIEN'="" D REA^BQIRMDR1 Q
. D FILE
;
D IFR^BQIRMDR2
;
RGR ; Register Reminders
S RGIEN=0
F S RGIEN=$O(^BQI(90507,RGIEN)) Q:'RGIEN D
. I $P(^BQI(90507,RGIEN,0),U,8)=1 Q
. S RMIEN=0
. F S RMIEN=$O(^BQI(90507,RGIEN,15,RMIEN)) Q:'RMIEN D
.. I $P(^BQI(90507,RGIEN,15,RMIEN,0),U,3)'=1 Q
.. S CODE="REG_"_RGIEN_"_"_RMIEN
.. NEW DA,IENS
.. S DA(1)=RGIEN,DA=RMIEN,IENS=$$IENS^DILF(.DA)
.. S RCLIN=$$GET1^DIQ(90507.015,IENS,.05,"E")
.. S TEXT=$$GET1^DIQ(90507.015,IENS,.01,"E")
.. S RCAT="Care Management",SOURCE="Reminders",GCAT="",GCLIN=""
.. S HDR="T00050"_CODE,DEF=0
.. S RIEN=$O(^BQI(90506.1,"B",CODE,""))
.. I RIEN="" D FILE Q
.. D REA^BQIRMDR1
D EHR^BQIRMDR1
D CMET^BQIRMDR1
;
; Make sure that the new style cross-references are set
NEW DIK
S DIK="^BQI(90506.1,",DIK(1)="3.01"
D ENALL^DIK
;
NOT ; Check for any newly inactive reminders and send notifications
S RIEN=""
F S RIEN=$O(^BQI(90506.1,"AC","R",RIEN)) Q:RIEN="" D
. I $P(^BQI(90506.1,RIEN,0),U,10)'=1 Q
. I $P(^BQI(90506.1,RIEN,0),U,11)<DT Q
. NEW OWNR,PLIEN,SUBJECT,CODE
. S CODE=$P(^BQI(90506.1,RIEN,0),U,1)
. S TEXT=$P(^BQI(90506.1,RIEN,0),U,3)
. S OWNR=0
. F S OWNR=$O(^BQICARE(OWNR)) Q:'OWNR D
.. S PLIEN=0,QFL=0
.. F S PLIEN=$O(^BQICARE(OWNR,1,PLIEN)) Q:'PLIEN D Q:QFL
... I $O(^BQICARE(OWNR,1,PLIEN,22,"B",CODE,""))'="" D
.... S SUBJECT="Reminder ["_TEXT_"] has been deactivated/deleted. You may need to change your panel Reminder View layouts."
.... I '$$DUP^BQINOTF(OWNR,SUBJECT,DT) S QFL=1 Q
.... D ADD^BQINOTF("",OWNR,SUBJECT,,1)
.... S QFL=1
... S SHR=0,QFL=0
... F S SHR=$O(^BQICARE(OWNR,1,PLIEN,30,SHR)) Q:'SHR D Q:QFL
.... I $O(^BQICARE(OWNR,1,PLIEN,30,SHR,22,"B",CODE,""))'="" D
..... S SUBJECT="Reminder ["_TEXT_"] has been deactivated/deleted. You may need to change your panel Reminder View layouts."
..... I '$$DUP^BQINOTF(SHR,SUBJECT,DT) S QFL=1 Q
..... D ADD^BQINOTF("",SHR,SUBJECT,,1)
..... S QFL=1
;
D EN^BQIRMCHK
Q
;
FILE ;File record
NEW DA,X,DIC,DLAYGO
S DIC="^BQI(90506.1,",DIC(0)="L",X=CODE
K DO,DD D FILE^DICN
S DA=+Y I DA=-1 S ERROR=1 Q
;S HIEN=DA
S BQIUPD(90506.1,DA_",",.03)=TEXT
;S BQIUPD(90506.1,DA_",",2.01)=SOURCE
;S BQIUPD(90506.1,DA_",",2.02)=GCAT
;S BQIUPD(90506.1,DA_",",2.03)=RCAT
S BQIUPD(90506.1,DA_",",3.03)=RCAT
;S BQIUPD(90506.1,DA_",",2.05)=RCLIN
;S BQIUPD(90506.1,DA_",",2.06)=GCLIN
S BQIUPD(90506.1,DA_",",.08)=HDR
S BQIUPD(90506.1,DA_",",.09)=$S($G(DEF)=1:"D",1:"O")
S BQIUPD(90506.1,DA_",",3.04)=$S($G(DEF)=1:"Default",1:"Optional")
S BQIUPD(90506.1,DA_",",.15)=100
I SOURCE="Reminders" D
. S BQIUPD(90506.1,DA_",",1)="S VAL=$$REM^BQIULPT(DFN,STVW)"
. I CODE["AUTTIMM" D
.. I 'IMOK S BQIUPD(90506.1,DA_",",3.07)=1 Q
.. I IMOK S BQIUPD(90506.1,DA_",",3.07)="@"
I SOURCE="Performance" S BQIUPD(90506.1,DA_",",1)="S VAL=$$PER^BQIULPT(DFN,STVW)"
D FILE^DIE("","BQIUPD","ERROR")
;
S BQIUPD(90506.1,DA_",",3.01)=SOURCE
S BQIUPD(90506.1,DA_",",3.02)=RCLIN
S BQIUPD(90506.1,DA_",",3.03)=RCAT
S BQIUPD(90506.1,DA_",",3.04)=$S($G(DEF)=1:"Default",1:"Optional")
D FILE^DIE("E","BQIUPD","ERROR")
;
;I $D(ERROR)
; Send a notification that a new reminder was added
NEW OWNR,PLIEN,SUBJECT
S OWNR=0
F S OWNR=$O(^BQICARE(OWNR)) Q:'OWNR D
. S SUBJECT="Reminder ["_TEXT_"] has been newly added. You may want to update your panel Reminder View layouts."
. D ADD^BQINOTF("",OWNR,SUBJECT,,1)
;
I TJOB="Weekly" Q
;
; Create a reminder record for every patient with new reminder
NEW RMN
I $P($G(^XTMP("BQIRMOM",0)),U,2)'=$$DT^XLFDT() D
. S RMN=0
. F S RMN=$O(^XTMP("BQIRMOM",RMN)) Q:RMN="" K ^XTMP("BQIRMOM",RMN)
. S ZTDESC="iCare Reminder Update",ZTRTN="ORM^BQITASK1",ZTIO=""
. S JBDATE=$$FMADD^XLFDT($$NOW^XLFDT(),,,+15)
. S ZTDTH=JBDATE
. D ^%ZTLOAD
. K ZTDESC,ZTRTN,ZTIO,JBDATE,ZTDTH,ZTSK
S ^XTMP("BQIRMOM",0)=$$FMADD^XLFDT(DT,1)_U_$$DT^XLFDT()_U_"Newly activated Reminders"
S RMN=$O(^XTMP("BQIRMOM",""),-1)+1
I RCAT'="Care Management" S ^XTMP("BQIRMOM",RMN)=RCAT_U_HIEN_U_CODE
I RCAT="Care Management" S ^XTMP("BQIRMOM",RMN)=RCAT_U_U_CODE
Q
;
ERR ;
;
NEW DA
S DA=$O(^BQI(90508,0))
S BQIUPD(90508,DA_",",3.12)="@"
S BQIUPD(90508,DA_",",4.09)="@"
D FILE^DIE("","BQIUPD")
K BQIUPD
S ERRCNT=$G(ERRCNT)+1
;
D ^%ZTER
Q
BQIRMDR ;PRXM/HC/ALA-Find all reminder values ; 15 Mar 2007 2:30 PM
+1 ;;2.5;ICARE MANAGEMENT SYSTEM;;May 24, 2016;Build 27
+2 ;
PAT(DFN,REF) ;EP
+1 NEW APCHSPAT,APCHSAGE,APCHSEX,APCHSANY,APCHSITM,APCHNON,APCHSURX
+2 NEW ZAPCHS,APCHSCVD,APCHSITI,APCHLBE,APCHLCOL,APCHOVR,APCHSBP
+3 NEW AMQQTAXN,APCHBHD,AMQQTAXN,APCHBHD,APCHC,APCHIMMC,APCHLADX
+4 NEW APCHLED,APCHLEX,APCHLEXB,APCHLHF,APCHLPV,APCHLSIG,APCHNEXT
+5 NEW APCHSBRK,APCHSBWR,APCHSC,APCHSCAT,APCHSCKP,APCHSCRI,APCHSDAT
+6 NEW APCHSDF,APCHSDF1,APCHSDIS,APCHSINT,APCHSIVD,APCHSKD,APCHSMSC
+7 NEW APCHSDO,APCHSDOB,APCHSDT,APCHSDUE,APCHSEXD,APCHSEXN,APCHSFLX
+8 NEW APCHSKDT,APCHSKN,APCHSKND,APCHSLAB,APCHSLBD,APCHSLDT,APCHSLP
+9 NEW APCHSMAM,APCHSMDT,APCHSYRY,APCHT,APCHTAXN,RIEN,DIC,DAYS,CODE
+10 NEW APCHSMSD,APCHSNPG,APCHSOLD,APCHSQIT,APCHSTEX,APCHSURD,APCHSWD
+11 NEW APCHTEST,APCHX,APCLAST,RMHDR,APCHNME,IMM,IMN,OT,OTH,REMTEXT,RJ
+12 NEW VER,NAME,APCHA,APCHCOLW,APCHDX4,APCHHR,APCHIC,APCHLR,APCHLSTR
+13 NEW APCHWHI,APCHWHL,APCHWHN,IQFL,IMOK,APCHRVAL,APCHSWHR,APCHR
+14 NEW APCHNUMD,APCHLAST
+15 ;
+16 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRMDR D UNWIND^%ZTER"
+17 ;
+18 ; Sometimes if Postmaster is the Task owner, DUZ is not defined correctly for some reminders
+19 IF $GET(DUZ(2))=""!(DUZ=.5)
MERGE DUZ=^XTMP("BQIRMDR","DUZ")
+20 ;
+21 SET IMOK=0
IF $$PATCH^XPDUTL("BI*8.3*1")
SET IMOK=1
+22 ; Delete any previous reminders
+23 NEW DA,DIK
+24 SET DA(1)=DFN
SET DA=0
SET DIK="^BQIPAT("_DA(1)_",40,"
+25 FOR
SET DA=$ORDER(^BQIPAT(DFN,40,DA))
IF 'DA
QUIT
DO ^DIK
+26 ;
+27 ; If deceased, don't include
+28 ;I $P($G(^DPT(DFN,.35)),U,1)'="" Q
+29 ; If no active HRN, don't include
+30 ;I '$$HRN^BQIUL1(DFN) Q
+31 ; If no visit in last 3 years, quit
+32 ;I '$$VTHR^BQIUL1(DFN) Q
+33 ;
+34 SET REF=$GET(REF,0)
+35 ;
+36 SET APCHSPAT=DFN
+37 SET APCHSDOB=$PIECE($GET(^DPT(APCHSPAT,0)),U,3)
IF APCHSDOB=""
QUIT
+38 SET APCHSAGE=$$AGE^BQIAGE(APCHSPAT)
+39 SET APCHSEX=$PIECE(^DPT(APCHSPAT,0),U,2)
+40 SET APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
+41 SET (APCHSANY,APCHSITM)=0
SET APCHNON=1
SET APCHSURX=""
+42 SET APCHSCKP="S APCHSQIT=1 Q"
+43 SET APCHSBRK="Q"
+44 SET APCHSNPG=0
+45 KILL APCHSTEX
+46 ;
+47 ; If patient not in BQIPAT yet, add them
+48 IF $GET(^BQIPAT(DFN,0))=""
Begin DoDot:1
+49 NEW DIC,X,DINUM,DLAYGO
+50 SET (X,DINUM)=DFN
SET DLAYGO=90507.5
SET DIC="^BQIPAT("
SET DIC(0)="L"
+51 KILL DO,DD
DO FILE^DICN
End DoDot:1
+52 ;
+53 SET RIEN=""
+54 FOR
SET RIEN=$ORDER(^BQI(90506.1,"AC","R",RIEN))
IF RIEN=""
QUIT
Begin DoDot:1
+55 IF $PIECE(^BQI(90506.1,RIEN,0),U,10)=1
QUIT
+56 SET NAME=$PIECE(^BQI(90506.1,RIEN,0),U,3)
+57 SET CODE=$PIECE(^BQI(90506.1,RIEN,0),U,1)
+58 SET HIEN=$PIECE(CODE,"_",2)
+59 ;
+60 IF $PIECE(CODE,"_",1)="REG"
DO REG^BQIRMDR1(DFN,CODE)
QUIT
+61 ;
+62 IF $PIECE(CODE,"_",1)="EHR"
DO EMR^BQIRMDR1(DFN,CODE)
QUIT
+63 ;
+64 IF $PIECE(CODE,"_",1)="CMET"
DO CMT^BQIRMDR1(DFN,CODE)
QUIT
+65 ;
+66 IF $PIECE(CODE,"_",1)="AUTTIMM"
Begin DoDot:2
+67 SET NAME="IMMUNIZATIONS"
+68 SET HIEN=$$FIND1^DIC(9001018,"","Q",NAME,"B","","ERROR")
End DoDot:2
+69 ;
+70 IF $PIECE(CODE,"_",1)="COLO"
Begin DoDot:2
+71 SET NAME="COLORECTAL CA-SCOPE/XRAY"
+72 SET HIEN=$$FIND1^DIC(9001018,"","Q",NAME,"B","","ERROR")
End DoDot:2
+73 ;
+74 DO RMR(DFN,HIEN)
End DoDot:1
+75 ;
+76 ; Fill in all missing immunizations
+77 SET IEN=""
+78 FOR
SET IEN=$ORDER(^BQI(90506.1,"AC","R",IEN))
IF IEN=""
QUIT
Begin DoDot:1
+79 IF $PIECE(^BQI(90506.1,IEN,0),U,10)=1
QUIT
+80 SET CODE=$PIECE(^BQI(90506.1,IEN,0),U,1)
+81 IF CODE["AUTTIMM"
QUIT
+82 IF $ORDER(^BQIPAT(DFN,40,"B",CODE,""))'=""
QUIT
+83 IF $EXTRACT(CODE,1,3)="REG"
QUIT
+84 IF $EXTRACT(CODE,1,4)="CMET"
QUIT
+85 SET (REMDUE,REMLAST,REMNEXT)=""
+86 DO FIL
End DoDot:1
+87 ;
+88 DO IZ^BQIRMDR2(DFN)
+89 QUIT
+90 ;
RMR(DFN,HIEN) ;EP
+1 NEW RCIEN,RCFILE,VISIT,APCHSPAT,APCHSDOB,APCHSAGE,APCHSCVD,APCHSCKP,RCFILE
+2 NEW APCHSBRK,APCHSNPG,APCHSANY,APCHSITM,APCHNON,APCHSURX,IMNIEN,REMDUE
+3 NEW REMLAST,REMNEXT
+4 SET APCHSPAT=DFN
+5 SET APCHSDOB=$PIECE($GET(^DPT(APCHSPAT,0)),U,3)
IF APCHSDOB=""
QUIT
+6 SET APCHSAGE=$$AGE^BQIAGE(APCHSPAT)
+7 SET APCHSEX=$PIECE(^DPT(APCHSPAT,0),U,2)
+8 SET APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
+9 SET (APCHSANY,APCHSITM)=0
SET APCHNON=1
SET APCHSURX=""
+10 SET APCHSCKP="S APCHSQIT=1 Q"
+11 SET APCHSBRK="Q"
+12 SET APCHSNPG=0
+13 KILL APCHSTEX
+14 SET APCHNME=$PIECE($GET(^APCHSURV(HIEN,0)),U,1)
IF APCHNME=""
QUIT
+15 ; Sometimes if Postmaster is the Task owner, DUZ is not defined correctly for some reminders
+16 IF $GET(DUZ(2))=""
MERGE DUZ=^XTMP("BQIRMDR","DUZ")
+17 SET IQFL=0
+18 IF $GET(IMOK)=""
SET IMOK=0
IF $$PATCH^XPDUTL("BI*8.3*1")
SET IMOK=1
+19 IF APCHNME="IMMUNIZATIONS"
Begin DoDot:1
+20 IF '$GET(REF)
IF 'IMOK
SET IQFL=1
QUIT
End DoDot:1
IF IQFL
QUIT
+21 SET X=$$GVHMR^APCHSMU(DFN,HIEN)
+22 IF APCHNME="IMMUNIZATIONS"
Begin DoDot:1
+23 IF X["Immunization Forecasting disabled"
QUIT
+24 IF +$PIECE(^BQI(90508,1,0),U,15)=0
QUIT
+25 NEW VALUE,IMM
+26 SET IMM=X
SET VALUE=""
+27 FOR PC=4:1:$LENGTH(IMM,"^")
SET IMN=$PIECE(IMM,U,PC)
IF IMN=""!(IMN[$CHAR(31))
QUIT
Begin DoDot:2
+28 SET REMNME=$PIECE(IMN,"|",1)
SET REMTEXT=$PIECE(IMN,"|",2)
+29 ; Need to strip off leading spaces
+30 FOR RJ=1:1
IF $EXTRACT(REMNME,RJ,RJ)'=" "
QUIT
+31 SET REMNME=$EXTRACT(REMNME,RJ,$LENGTH(REMNME))
+32 SET IMNIEN=$ORDER(^AUTTIMM("D",REMNME,""))
IF IMNIEN=""
QUIT
+33 IF IMOK
Begin DoDot:3
+34 SET VALUE=$$IMM^BQIREM(DFN,IMNIEN)
+35 SET REMDUE=$PIECE(VALUE,U,1)
SET REMNEXT=$PIECE(VALUE,U,2)
SET REMLAST=$PIECE(VALUE,U,3)
SET VISIT=$PIECE(VALUE,U,4)
SET RCIEN=$PIECE(VALUE,U,5)
+36 IF VISIT'=""
SET RCFILE=9000010.11
End DoDot:3
+37 IF 'IMOK
Begin DoDot:3
+38 SET X=REMNME_U_U_$$IMM^BQIREM(DFN,IMNIEN)
+39 DO PRS(X,HIEN)
End DoDot:3
+40 IF REMTEXT'=""
IF REMNEXT'=""
SET REMNEXT=REMTEXT_" ("_REMNEXT_")"
+41 IF REMTEXT'=""
IF REMNEXT=""
SET REMNEXT=REMTEXT
+42 SET CODE="AUTTIMM_"_IMNIEN
+43 DO FIL
End DoDot:2
End DoDot:1
QUIT
+44 IF APCHNME="COLORECTAL CA-SCOPE/XRAY"
Begin DoDot:1
+45 IF X["|"
Begin DoDot:2
+46 KILL OTH,OT,BQINEXT,BQIDUE,BQILAST
+47 SET OTH=X
+48 FOR PC=1:1:$LENGTH(OTH,"|")
SET OT=$PIECE(OTH,"|",PC)
IF OT=""
QUIT
Begin DoDot:3
+49 DO PRS(OT,HIEN)
+50 IF REMNEXT'=""
SET BQINEXT(REMNEXT)=""
+51 IF REMDUE'=""
SET BQIDUE(REMDUE)=""
+52 IF REMLAST'=""
SET BQILAST(REMLAST)=""
End DoDot:3
+53 SET REMNEXT=$ORDER(BQINEXT(""),-1)
+54 SET REMDUE=$ORDER(BQIDUE(""),-1)
+55 SET REMLAST=$ORDER(BQILAST(""),-1)
+56 DO FIL
End DoDot:2
QUIT
+57 IF $PIECE(X,U,2)=""
DO PRS(X,HIEN)
DO FIL
QUIT
+58 IF $PIECE(X,U,2)'=""
Begin DoDot:2
+59 SET OTH=$PIECE(X,U,4)
SET OT=$PIECE(X,U,1)_U_$PIECE(X,U,2)_U_$PIECE(OTH," ",2)_U_$$DATE^BQIUL1($PIECE(OTH," ",2))
+60 DO PRS(OT,HIEN)
+61 DO FIL
End DoDot:2
+62 DO PRS(X,HIEN)
+63 DO FIL
+64 QUIT
End DoDot:1
QUIT
+65 DO PRS(X,HIEN)
+66 DO FIL
+67 QUIT
+68 ;
PRS(VAL,HIEN) ;EP - Parse
+1 SET REMNME=$PIECE(VAL,U,1)
+2 IF X=""
SET REMNME=$PIECE(^APCHSURV(HIEN,0),U,1)
+3 SET REMDUE=""
SET REMLAST=""
+4 SET REMLAST=$PIECE(VAL,U,2)
SET REMNEXT=$PIECE(VAL,U,4)
SET REMDUE=$PIECE(VAL,U,5)
+5 SET VISIT=$PIECE(VAL,U,6)
SET RCIEN=$PIECE(VAL,U,7)
SET RCFILE=$PIECE(VAL,U,8)
+6 IF REMNEXT["/"
IF $EXTRACT(REMNEXT,1,1)'?.N
Begin DoDot:1
+7 IF $EXTRACT(REMNEXT,1,14)="MAY BE DUE NOW"
QUIT
+8 IF REMNEXT["per Women's Health system"
Begin DoDot:2
+9 NEW BQS,BQ,BQT,BQRDATE
+10 SET BQS=$FIND(REMNEXT,"(by")
SET BQRDATE=""
+11 FOR BQ=BQS+1:1
SET BQT=$EXTRACT(REMNEXT,BQ,BQ)
IF BQT=")"
QUIT
SET BQRDATE=BQRDATE_BQT
+12 IF $LENGTH(BQRDATE,"/")=2
SET BQRDATE=$PIECE(BQRDATE,"/",1)_"/01/"_$PIECE(BQRDATE,"/",2)
+13 SET REMDUE=BQRDATE
End DoDot:2
+14 IF APCHNME="COLORECTAL CA-SCOPE/XRAY"
Begin DoDot:2
+15 NEW XREMNXT,REMNME
+16 SET XREMNXT=$TRANSLATE(REMNEXT," ",":")
+17 SET REMNEXT=$PIECE(XREMNXT,":",$LENGTH(XREMNXT,":"))
+18 SET REMNME=$PIECE(XREMNXT,":",1)
+19 ;
End DoDot:2
End DoDot:1
+20 IF REMNEXT?2N1"/"2N1"/"2N
SET REMDUE=REMNEXT
+21 IF REMNEXT["MAY BE DUE NOW"
SET REMDUE=""
+22 IF REMNEXT["WAS DUE"
SET REMDUE=$PIECE($PIECE(REMNEXT,"WAS DUE ",2),")")
+23 ;
+24 QUIT
+25 ;
FIL ;EP - File the reminder
+1 NEW DIC,X,DINUM,DLAYGO,DA,IENS,BQIUPD
+2 SET X=CODE
SET DLAYGO=90507.54
SET DA(1)=DFN
SET DIC("P")=DLAYGO
+3 IF $GET(^BQIPAT(DA(1),40,0))=""
SET ^BQIPAT(DA(1),40,0)="^90507.54P^^"
+4 SET DIC="^BQIPAT("_DA(1)_",40,"
SET DIC(0)="L"
+5 ;K DO,DD D FILE^DICN
+6 DO ^DIC
+7 SET DA=+Y
IF DA=-1
QUIT
+8 IF REMDUE["."
SET REMDUE=REMDUE\1
+9 IF REMLAST["."
SET REMLAST=REMLAST\1
+10 SET IENS=$$IENS^DILF(.DA)
+11 IF $EXTRACT(REMDUE,4,7)="0000"
SET REMDUE=$EXTRACT(REMDUE,1,3)_"0101"
+12 SET BQIUPD(90507.54,IENS,.02)=$$DATE^BQIUL1(REMLAST)
+13 SET BQIUPD(90507.54,IENS,.03)=$GET(REMNEXT)
+14 SET BQIUPD(90507.54,IENS,.04)=$$DATE^BQIUL1(REMDUE)
+15 SET BQIUPD(90507.54,IENS,.05)=$$NOW^XLFDT()
+16 SET BQIUPD(90507.5,DFN_",",.08)=$$NOW^XLFDT()
+17 IF $$VFIELD^DILFD(90507.54,.06)
SET BQIUPD(90507.54,IENS,.06)=$GET(VISIT)
+18 IF $$VFIELD^DILFD(90507.54,.07)
SET BQIUPD(90507.54,IENS,.07)=$GET(RCIEN)
+19 IF $$VFIELD^DILFD(90507.54,.08)
SET BQIUPD(90507.54,IENS,.08)=$GET(RCFILE)
+20 DO FILE^DIE("","BQIUPD","ERROR")
+21 ;
+22 ;Check reminder notification is completed
+23 DO COMP^BQINOTR(DFN,CODE)
+24 QUIT
+25 ;
CHK(TJOB) ;EP - Check for reminders and add new ones if found and inactivate
+1 ; ones no longer in list
+2 ; Input
+3 ; TJOB - Type of job
+4 ;
+5 SET REF=0
+6 ; Delete reminders in 'All Reminders'
+7 NEW DIC,DIE,DA,NDX,NDX2,RMNDR,X,Y,DR,REMNDX,CALL,TAG
+8 SET REMNDX=$$FIND1^DIC(9001015,"","","ALL REMINDERS","B","","")
+9 ; Kill Health Summary nodes
+10 SET DA(1)=REMNDX
SET DA=0
SET DIK="^APCHSCTL("_DA(1)_",5,"
+11 FOR
SET DA=$ORDER(^APCHSCTL(REMNDX,5,DA))
IF 'DA
QUIT
DO ^DIK
+12 ;
+13 ; Add reminders back to 'All Reminders'
+14 SET DA(1)=REMNDX
SET DLAYGO=9001015.06
SET DIC(0)="LZ"
+15 SET DIC="^APCHSCTL("_DA(1)_",5,"
+16 ;
+17 SET RMNDR=0
+18 FOR
SET RMNDR=$ORDER(^APCHSURV(RMNDR))
IF 'RMNDR
QUIT
Begin DoDot:1
+19 IF $$GET1^DIQ(9001018,RMNDR,.03,"I")=1
Begin DoDot:2
+20 ; if not an official IHS reminder, quit
+21 IF $$GET1^DIQ(9001018,RMNDR,.06,"I")'=1
QUIT
+22 ; if it is a treatment prompt instead, quit
+23 IF $$GET1^DIQ(9001018,RMNDR,.07,"I")="T"
QUIT
+24 SET NDX=+$PIECE(^APCHSURV(RMNDR,0),U,5)
+25 SET (DA,NDX2)=(NDX*100)+RMNDR
+26 SET X=NDX2
+27 KILL DO,DD
DO FILE^DICN
+28 SET DA=+Y
SET DIE=DIC
+29 SET DR="1////"_RMNDR
+30 DO ^DIE
+31 QUIT
End DoDot:2
End DoDot:1
+32 ;
+33 ; Inactive all reminders
+34 KILL BQIUPD
+35 NEW SRCE,QFL
+36 SET IEN=""
+37 FOR
SET IEN=$ORDER(^BQI(90506.1,"AC","R",IEN))
IF IEN=""
QUIT
Begin DoDot:1
+38 SET BQIUPD(90506.1,IEN_",",.1)=1
+39 IF $PIECE(^BQI(90506.1,IEN,0),U,11)=""
SET BQIUPD(90506.1,IEN_",",.11)=DT
End DoDot:1
+40 DO FILE^DIE("","BQIUPD","ERROR")
+41 KILL BQIUPD
+42 ;
FND ; Find the reminders and either reactivate or create new entry
+1 NEW BQIRM,SOURCE,DEF,ERROR,GCAT,RCAT,RCLIN,GCLIN,HDR,QFL,TEXT
+2 SET BQIRM=$$FIND1^DIC(9001015,"","","ALL REMINDERS","B","","")
+3 SET IEN=0
SET SOURCE="Reminders"
SET GCAT=""
SET GCLIN=""
+4 FOR
SET IEN=$ORDER(^APCHSCTL(BQIRM,5,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+5 SET HIEN=$PIECE(^APCHSCTL(BQIRM,5,IEN,0),U,2)
+6 IF $PIECE($GET(^APCHSURV(HIEN,0)),U,3)'=1
QUIT
+7 IF $PIECE($GET(^APCHSURV(HIEN,0)),U,7)="T"
QUIT
+8 SET TEXT=$PIECE(^APCHSURV(HIEN,0),U,1)
SET DEF=$PIECE(^APCHSURV(HIEN,0),U,6)
+9 SET CALL=$PIECE(^APCHSURV(HIEN,0),U,2)
SET TAG=$PIECE(CALL,";",1)
+10 IF TAG=""
QUIT
+11 SET RCAT="Health Summary"
SET RCLIN=$$GET1^DIQ(9001018,HIEN_",",.05,"E")
+12 IF RCLIN=""
SET RCLIN="No Category"
+13 ; if reminder is an official IHS reminder with a category of GENERAL
+14 ; make it a default
+15 SET DEF=$SELECT(DEF=1&(RCLIN="GENERAL"):1,1:0)
+16 IF TEXT="IMMUNIZATIONS"
Begin DoDot:2
+17 IF $GET(IMOK)=""
SET IMOK=0
IF $$PATCH^XPDUTL("BI*8.3*1")
SET IMOK=1
+18 IF +$PIECE(^BQI(90508,1,0),U,15)=0
QUIT
+19 NEW IIEN
+20 SET IIEN=0
+21 FOR
SET IIEN=$ORDER(^AUTTIMM(IIEN))
IF 'IIEN
QUIT
Begin DoDot:3
+22 ; If inactive, quit
+23 IF $PIECE(^AUTTIMM(IIEN,0),U,7)=1
QUIT
+24 SET TEXT=$PIECE(^AUTTIMM(IIEN,0),U,2)
+25 SET CODE="AUTTIMM_"_IIEN
SET RCLIN="IZ Forecast"
+26 SET HDR="T00050"_CODE
+27 SET RIEN=""
SET RIEN=$ORDER(^BQI(90506.1,"B",CODE,RIEN))
+28 IF RIEN'=""
DO REA^BQIRMDR1
QUIT
+29 DO FILE
End DoDot:3
End DoDot:2
QUIT
+30 ;
+31 ; If IMMUNIZATION category and disabled, quit
+32 IF $$GET1^DIQ(9001018,HIEN_",",.05,"E")["IMMUNIZATION"
IF +$PIECE(^BQI(90508,1,0),U,18)=0
QUIT
+33 SET CODE=TAG_"_"_HIEN
+34 SET HDR="T00050"_CODE
+35 SET RIEN=""
SET RIEN=$ORDER(^BQI(90506.1,"B",CODE,RIEN))
+36 IF RIEN'=""
DO REA^BQIRMDR1
QUIT
+37 DO FILE
End DoDot:1
+38 ;
+39 DO IFR^BQIRMDR2
+40 ;
RGR ; Register Reminders
+1 SET RGIEN=0
+2 FOR
SET RGIEN=$ORDER(^BQI(90507,RGIEN))
IF 'RGIEN
QUIT
Begin DoDot:1
+3 IF $PIECE(^BQI(90507,RGIEN,0),U,8)=1
QUIT
+4 SET RMIEN=0
+5 FOR
SET RMIEN=$ORDER(^BQI(90507,RGIEN,15,RMIEN))
IF 'RMIEN
QUIT
Begin DoDot:2
+6 IF $PIECE(^BQI(90507,RGIEN,15,RMIEN,0),U,3)'=1
QUIT
+7 SET CODE="REG_"_RGIEN_"_"_RMIEN
+8 NEW DA,IENS
+9 SET DA(1)=RGIEN
SET DA=RMIEN
SET IENS=$$IENS^DILF(.DA)
+10 SET RCLIN=$$GET1^DIQ(90507.015,IENS,.05,"E")
+11 SET TEXT=$$GET1^DIQ(90507.015,IENS,.01,"E")
+12 SET RCAT="Care Management"
SET SOURCE="Reminders"
SET GCAT=""
SET GCLIN=""
+13 SET HDR="T00050"_CODE
SET DEF=0
+14 SET RIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
+15 IF RIEN=""
DO FILE
QUIT
+16 DO REA^BQIRMDR1
End DoDot:2
End DoDot:1
+17 DO EHR^BQIRMDR1
+18 DO CMET^BQIRMDR1
+19 ;
+20 ; Make sure that the new style cross-references are set
+21 NEW DIK
+22 SET DIK="^BQI(90506.1,"
SET DIK(1)="3.01"
+23 DO ENALL^DIK
+24 ;
NOT ; Check for any newly inactive reminders and send notifications
+1 SET RIEN=""
+2 FOR
SET RIEN=$ORDER(^BQI(90506.1,"AC","R",RIEN))
IF RIEN=""
QUIT
Begin DoDot:1
+3 IF $PIECE(^BQI(90506.1,RIEN,0),U,10)'=1
QUIT
+4 IF $PIECE(^BQI(90506.1,RIEN,0),U,11)<DT
QUIT
+5 NEW OWNR,PLIEN,SUBJECT,CODE
+6 SET CODE=$PIECE(^BQI(90506.1,RIEN,0),U,1)
+7 SET TEXT=$PIECE(^BQI(90506.1,RIEN,0),U,3)
+8 SET OWNR=0
+9 FOR
SET OWNR=$ORDER(^BQICARE(OWNR))
IF 'OWNR
QUIT
Begin DoDot:2
+10 SET PLIEN=0
SET QFL=0
+11 FOR
SET PLIEN=$ORDER(^BQICARE(OWNR,1,PLIEN))
IF 'PLIEN
QUIT
Begin DoDot:3
+12 IF $ORDER(^BQICARE(OWNR,1,PLIEN,22,"B",CODE,""))'=""
Begin DoDot:4
+13 SET SUBJECT="Reminder ["_TEXT_"] has been deactivated/deleted. You may need to change your panel Reminder View layouts."
+14 IF '$$DUP^BQINOTF(OWNR,SUBJECT,DT)
SET QFL=1
QUIT
+15 DO ADD^BQINOTF("",OWNR,SUBJECT,,1)
+16 SET QFL=1
End DoDot:4
+17 SET SHR=0
SET QFL=0
+18 FOR
SET SHR=$ORDER(^BQICARE(OWNR,1,PLIEN,30,SHR))
IF 'SHR
QUIT
Begin DoDot:4
+19 IF $ORDER(^BQICARE(OWNR,1,PLIEN,30,SHR,22,"B",CODE,""))'=""
Begin DoDot:5
+20 SET SUBJECT="Reminder ["_TEXT_"] has been deactivated/deleted. You may need to change your panel Reminder View layouts."
+21 IF '$$DUP^BQINOTF(SHR,SUBJECT,DT)
SET QFL=1
QUIT
+22 DO ADD^BQINOTF("",SHR,SUBJECT,,1)
+23 SET QFL=1
End DoDot:5
End DoDot:4
IF QFL
QUIT
End DoDot:3
IF QFL
QUIT
End DoDot:2
End DoDot:1
+24 ;
+25 DO EN^BQIRMCHK
+26 QUIT
+27 ;
FILE ;File record
+1 NEW DA,X,DIC,DLAYGO
+2 SET DIC="^BQI(90506.1,"
SET DIC(0)="L"
SET X=CODE
+3 KILL DO,DD
DO FILE^DICN
+4 SET DA=+Y
IF DA=-1
SET ERROR=1
QUIT
+5 ;S HIEN=DA
+6 SET BQIUPD(90506.1,DA_",",.03)=TEXT
+7 ;S BQIUPD(90506.1,DA_",",2.01)=SOURCE
+8 ;S BQIUPD(90506.1,DA_",",2.02)=GCAT
+9 ;S BQIUPD(90506.1,DA_",",2.03)=RCAT
+10 SET BQIUPD(90506.1,DA_",",3.03)=RCAT
+11 ;S BQIUPD(90506.1,DA_",",2.05)=RCLIN
+12 ;S BQIUPD(90506.1,DA_",",2.06)=GCLIN
+13 SET BQIUPD(90506.1,DA_",",.08)=HDR
+14 SET BQIUPD(90506.1,DA_",",.09)=$SELECT($GET(DEF)=1:"D",1:"O")
+15 SET BQIUPD(90506.1,DA_",",3.04)=$SELECT($GET(DEF)=1:"Default",1:"Optional")
+16 SET BQIUPD(90506.1,DA_",",.15)=100
+17 IF SOURCE="Reminders"
Begin DoDot:1
+18 SET BQIUPD(90506.1,DA_",",1)="S VAL=$$REM^BQIULPT(DFN,STVW)"
+19 IF CODE["AUTTIMM"
Begin DoDot:2
+20 IF 'IMOK
SET BQIUPD(90506.1,DA_",",3.07)=1
QUIT
+21 IF IMOK
SET BQIUPD(90506.1,DA_",",3.07)="@"
End DoDot:2
End DoDot:1
+22 IF SOURCE="Performance"
SET BQIUPD(90506.1,DA_",",1)="S VAL=$$PER^BQIULPT(DFN,STVW)"
+23 DO FILE^DIE("","BQIUPD","ERROR")
+24 ;
+25 SET BQIUPD(90506.1,DA_",",3.01)=SOURCE
+26 SET BQIUPD(90506.1,DA_",",3.02)=RCLIN
+27 SET BQIUPD(90506.1,DA_",",3.03)=RCAT
+28 SET BQIUPD(90506.1,DA_",",3.04)=$SELECT($GET(DEF)=1:"Default",1:"Optional")
+29 DO FILE^DIE("E","BQIUPD","ERROR")
+30 ;
+31 ;I $D(ERROR)
+32 ; Send a notification that a new reminder was added
+33 NEW OWNR,PLIEN,SUBJECT
+34 SET OWNR=0
+35 FOR
SET OWNR=$ORDER(^BQICARE(OWNR))
IF 'OWNR
QUIT
Begin DoDot:1
+36 SET SUBJECT="Reminder ["_TEXT_"] has been newly added. You may want to update your panel Reminder View layouts."
+37 DO ADD^BQINOTF("",OWNR,SUBJECT,,1)
End DoDot:1
+38 ;
+39 IF TJOB="Weekly"
QUIT
+40 ;
+41 ; Create a reminder record for every patient with new reminder
+42 NEW RMN
+43 IF $PIECE($GET(^XTMP("BQIRMOM",0)),U,2)'=$$DT^XLFDT()
Begin DoDot:1
+44 SET RMN=0
+45 FOR
SET RMN=$ORDER(^XTMP("BQIRMOM",RMN))
IF RMN=""
QUIT
KILL ^XTMP("BQIRMOM",RMN)
+46 SET ZTDESC="iCare Reminder Update"
SET ZTRTN="ORM^BQITASK1"
SET ZTIO=""
+47 SET JBDATE=$$FMADD^XLFDT($$NOW^XLFDT(),,,+15)
+48 SET ZTDTH=JBDATE
+49 DO ^%ZTLOAD
+50 KILL ZTDESC,ZTRTN,ZTIO,JBDATE,ZTDTH,ZTSK
End DoDot:1
+51 SET ^XTMP("BQIRMOM",0)=$$FMADD^XLFDT(DT,1)_U_$$DT^XLFDT()_U_"Newly activated Reminders"
+52 SET RMN=$ORDER(^XTMP("BQIRMOM",""),-1)+1
+53 IF RCAT'="Care Management"
SET ^XTMP("BQIRMOM",RMN)=RCAT_U_HIEN_U_CODE
+54 IF RCAT="Care Management"
SET ^XTMP("BQIRMOM",RMN)=RCAT_U_U_CODE
+55 QUIT
+56 ;
ERR ;
+1 ;
+2 NEW DA
+3 SET DA=$ORDER(^BQI(90508,0))
+4 SET BQIUPD(90508,DA_",",3.12)="@"
+5 SET BQIUPD(90508,DA_",",4.09)="@"
+6 DO FILE^DIE("","BQIUPD")
+7 KILL BQIUPD
+8 SET ERRCNT=$GET(ERRCNT)+1
+9 ;
+10 DO ^%ZTER
+11 QUIT
