BQIRMDR1 ;VNGT/HS/ALA-Reminders continued ; 06 Nov 2008 3:53 PM
;;2.5;ICARE MANAGEMENT SYSTEM;;May 24, 2016;Build 27
;
REA ;EP - Reactivate record
NEW DIE,DR,DA,CODE
S DA=RIEN
S BQIUPD(90506.1,DA_",",.1)="@"
S BQIUPD(90506.1,DA_",",.11)="@"
S BQIUPD(90506.1,DA_",",.03)=TEXT
S BQIUPD(90506.1,DA_",",.08)=HDR
S BQIUPD(90506.1,DA_",",.09)=$S($G(DEF)=1:"D",1:"O")
S CODE=$P(^BQI(90506.1,DA,0),U,1)
I CODE["AUTTIMM" D
. I 'IMOK S BQIUPD(90506.1,DA_",",3.07)=1 Q
. I IMOK S BQIUPD(90506.1,DA_",",3.07)="@"
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")
;
; Make sure that the new style cross-references are set
;NEW DIK
;S DIK="^BQI(90506.1,",DIK(1)="3.01"
;D ENALL^DIK
;
Q
;
EHR ;
NEW EHIEN,ETLP,FN,IMM,PXN,FT,AST,UTEXT
S SOURCE="Reminders",DEF=0,RCLIN=""
S EHIEN=0
F S EHIEN=$O(^PXD(811.9,EHIEN)) Q:'EHIEN D
. I $G(^PXD(811.9,EHIEN,0))="" Q
. ; If it is inactive, ignore
. I $P(^PXD(811.9,EHIEN,0),U,6)=1 Q
. S TEXT=$P(^PXD(811.9,EHIEN,0),U,3) I TEXT="" Q
. S UTEXT=$$UP^XLFSTR(TEXT)
. S FN=0,IMM=0,AST=0
. ;I UTEXT="Immunization Forecast" S IMM=1
. I UTEXT["IMMUNIZATION" S IMM=1
. I $P(^PXD(811.9,EHIEN,0),U,1)[" IMMUN" S IMM=1
. F S FN=$O(^PXD(811.9,EHIEN,20,FN)) Q:'FN D
.. NEW DA,IENS
.. S DA(1)=EHIEN,DA=FN,IENS=$$IENS^DILF(.DA)
.. I $$GET1^DIQ(811.902,IENS,.01,"E")["IMMUNIZATION" S IMM=1 Q
.. I $$GET1^DIQ(811.902,IENS,.01,"E")["ASTHMA" S AST=1 Q
.. ;
.. I $$GET1^DIQ(811.902,IENS,.01,"I")["PXRMD(811.5" D
... S PXN=$P($$GET1^DIQ(811.902,IENS,.01,"I"),";",1)
... S FT=0
... F S FT=$O(^PXRMD(811.5,PXN,20,FT)) Q:'FT D
.... NEW DA,IENS
.... S DA(1)=PXN,DA=FT,IENS=$$IENS^DILF(.DA)
.... I $$GET1^DIQ(811.52,IENS,.01,"I")["AUTTIMM" S IMM=1
. ;If the finding contains IMMUNIZATIONS and it is not turned on, quit
. ;I IMM,+$P(^BQI(90508,1,0),U,16)=0 Q
. I IMM Q
. ;If the finding contains ASTHMA and it is not turned on, quit
. I AST,+$P(^BQI(90508,1,0),U,17)=0 Q
. S RCLIN=$$GET1^DIQ(811.9,EHIEN_",",100,"E")
. S RCLIN=$$LOWER^VALM1(RCLIN)
. S RCAT="EHR Clinical Reminders"
. S CODE="EHR_"_EHIEN
. S HDR="T00050"_CODE
. S RIEN=$O(^BQI(90506.1,"B",CODE,""))
. I RIEN="" D FILE^BQIRMDR Q
. S ETLP=0 K ^BQI(90506.1,RIEN,4)
. I $G(^BQI(90506.1,RIEN,4,0))="" S ^BQI(90506.1,RIEN,4,0)="^^"
. F S ETLP=$O(^PXD(811.9,EHIEN,1,ETLP)) Q:'ETLP S ^BQI(90506.1,RIEN,4,ETLP,0)=^PXD(811.9,EHIEN,1,ETLP,0)
. D REA
Q
;
EMR(APCHSPAT,CODE) ;EP
NEW EHIEN,RNAME
S EHIEN=$P(CODE,"_",2)
I $G(ERRCNT)="" S ERRCNT=0
;
S (REMDUE,REMLAST,REMNEXT,RDATA)=""
S DFN=APCHSPAT
D MAIN^PXRM(DFN,EHIEN,1,1)
I $G(%ZTERZE)'="" S ERRCNT=ERRCNT+1 K %ZTERZE Q
S RNAME=$O(^TMP("PXRHM",$J,EHIEN,""))
I RNAME'="" D
. S RDATA=$G(^TMP("PXRHM",$J,EHIEN,RNAME))
S REMDUE=$P(RDATA,U,2),REMLAST=$P(RDATA,U,3),REMNEXT=$P(RDATA,U,1)
;
D FIL^BQIRMDR
Q
;
VAR ;EP - Set variables
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
Q
;
REG(APCHSPAT,CODE) ;EP
NEW REG,HIEN,EXEC,RIEN,TAG,CMN,DEN,VAL
S REG=$P(CODE,"_",2)
S HIEN=$P(CODE,"_",3)
;
; Check if tag is associated with register
S TAG=$O(^BQI(90506.2,"AD",REG,""))
I TAG="" Q
S CMN=$O(^BQI(90506.5,"D",REG,""))
I CMN="" Q
S DEN=$G(^BQI(90506.5,CMN,1))
I DEN'="" X DEN I VAL'="Y" Q
;S RIEN=$O(^BQIREG("C",APCHSPAT,TAG,""))
;I RIEN="" Q
; Check if person has an active tag
;S CSTAT=$P(^BQIREG(RIEN,0),U,3)
;I '$$ACST^BQITDUTL(CSTAT) Q
;I CSTAT'="P"&(CSTAT'="A") Q
;I CSTAT'="P"&(CSTAT'="A") S RQFL=0 D Q:RQFL
;. I '$$ORG^BQITDUTL(APCHSPAT,REG) S RQFL=1
;
S EXEC="D "_$P(^BQI(90507,REG,15,HIEN,0),U,2)
S EXEC=$TR(EXEC,";","^")
S (REMDUE,REMLAST,REMNEXT)=""
S DFN=APCHSPAT
X EXEC
;
D FIL^BQIRMDR
Q
;
CMET ;
NEW CIEN
S SOURCE="Reminders",DEF=0,RCLIN=""
S CIEN=0
F S CIEN=$O(^BTPW(90621,CIEN)) Q:'CIEN D
. ; If it is inactive, ignore
. I $P(^BTPW(90621,CIEN,0),U,3)'="" Q
. S TEXT=$P(^BTPW(90621,CIEN,0),U,1) I TEXT="N/A" Q
. S RCLIN=$$GET1^DIQ(90621,CIEN_",",.1,"E")
. S RCLIN=$$LOWER^VALM1(RCLIN)
. S RCAT="CMET"
. S CODE="CMET_"_CIEN
. S HDR="T00050"_CODE
. S RIEN=$O(^BQI(90506.1,"B",CODE,""))
. I RIEN="" D FILE^BQIRMDR Q
. D REA
Q
;
CMT(APCHSPAT,CODE) ;EP
NEW CRIEN
S CRIEN=$P(CODE,"_",2)
;
S (REMDUE,REMLAST,REMNEXT,RDATA)=""
S DFN=APCHSPAT
S RDATA=$$EVT^BTPWRMDR(APCHSPAT,CRIEN)
I RDATA="" Q
S REMDUE=$P(RDATA,U,7),REMLAST=$P(RDATA,U,5),VISIT=$P(RDATA,U,9)
D FIL^BQIRMDR
Q
;
VAL(CODE) ;EP - Get the name of a reminder given the CODE
NEW RN,NAME
S RN=$O(^BQI(90506.1,"B",CODE,"")) I RN="" Q ""
S NAME=$P(^BQI(90506.1,RN,0),"^",3)
I $P(CODE,"_",1)="AUTTIMM" Q ""
I $P(CODE,"_",1)'="EHR",$P(CODE,"_",1)'="REG",$P(CODE,"_",1)'="CMET" S NAME=NAME_" (HS)"
I $P(CODE,"_",1)="EHR" S NAME=NAME_" (EHR)"
I $P(CODE,"_",1)="REG" S NAME=NAME_" (HMS)"
I $P(CODE,"_",1)="CMET" S NAME=NAME_" (CMET)"
I $P(CODE,"_",1)="IZ" S NAME=NAME_" (Forecaster)"
Q NAME
BQIRMDR1 ;VNGT/HS/ALA-Reminders continued ; 06 Nov 2008 3:53 PM
+1 ;;2.5;ICARE MANAGEMENT SYSTEM;;May 24, 2016;Build 27
+2 ;
REA ;EP - Reactivate record
+1 NEW DIE,DR,DA,CODE
+2 SET DA=RIEN
+3 SET BQIUPD(90506.1,DA_",",.1)="@"
+4 SET BQIUPD(90506.1,DA_",",.11)="@"
+5 SET BQIUPD(90506.1,DA_",",.03)=TEXT
+6 SET BQIUPD(90506.1,DA_",",.08)=HDR
+7 SET BQIUPD(90506.1,DA_",",.09)=$SELECT($GET(DEF)=1:"D",1:"O")
+8 SET CODE=$PIECE(^BQI(90506.1,DA,0),U,1)
+9 IF CODE["AUTTIMM"
Begin DoDot:1
+10 IF 'IMOK
SET BQIUPD(90506.1,DA_",",3.07)=1
QUIT
+11 IF IMOK
SET BQIUPD(90506.1,DA_",",3.07)="@"
End DoDot:1
+12 DO FILE^DIE("","BQIUPD","ERROR")
+13 ;
+14 SET BQIUPD(90506.1,DA_",",3.01)=SOURCE
+15 SET BQIUPD(90506.1,DA_",",3.02)=RCLIN
+16 SET BQIUPD(90506.1,DA_",",3.03)=RCAT
+17 SET BQIUPD(90506.1,DA_",",3.04)=$SELECT($GET(DEF)=1:"Default",1:"Optional")
+18 DO FILE^DIE("E","BQIUPD","ERROR")
+19 ;
+20 ; Make sure that the new style cross-references are set
+21 ;NEW DIK
+22 ;S DIK="^BQI(90506.1,",DIK(1)="3.01"
+23 ;D ENALL^DIK
+24 ;
+25 QUIT
+26 ;
EHR ;
+1 NEW EHIEN,ETLP,FN,IMM,PXN,FT,AST,UTEXT
+2 SET SOURCE="Reminders"
SET DEF=0
SET RCLIN=""
+3 SET EHIEN=0
+4 FOR
SET EHIEN=$ORDER(^PXD(811.9,EHIEN))
IF 'EHIEN
QUIT
Begin DoDot:1
+5 IF $GET(^PXD(811.9,EHIEN,0))=""
QUIT
+6 ; If it is inactive, ignore
+7 IF $PIECE(^PXD(811.9,EHIEN,0),U,6)=1
QUIT
+8 SET TEXT=$PIECE(^PXD(811.9,EHIEN,0),U,3)
IF TEXT=""
QUIT
+9 SET UTEXT=$$UP^XLFSTR(TEXT)
+10 SET FN=0
SET IMM=0
SET AST=0
+11 ;I UTEXT="Immunization Forecast" S IMM=1
+12 IF UTEXT["IMMUNIZATION"
SET IMM=1
+13 IF $PIECE(^PXD(811.9,EHIEN,0),U,1)[" IMMUN"
SET IMM=1
+14 FOR
SET FN=$ORDER(^PXD(811.9,EHIEN,20,FN))
IF 'FN
QUIT
Begin DoDot:2
+15 NEW DA,IENS
+16 SET DA(1)=EHIEN
SET DA=FN
SET IENS=$$IENS^DILF(.DA)
+17 IF $$GET1^DIQ(811.902,IENS,.01,"E")["IMMUNIZATION"
SET IMM=1
QUIT
+18 IF $$GET1^DIQ(811.902,IENS,.01,"E")["ASTHMA"
SET AST=1
QUIT
+19 ;
+20 IF $$GET1^DIQ(811.902,IENS,.01,"I")["PXRMD(811.5"
Begin DoDot:3
+21 SET PXN=$PIECE($$GET1^DIQ(811.902,IENS,.01,"I"),";",1)
+22 SET FT=0
+23 FOR
SET FT=$ORDER(^PXRMD(811.5,PXN,20,FT))
IF 'FT
QUIT
Begin DoDot:4
+24 NEW DA,IENS
+25 SET DA(1)=PXN
SET DA=FT
SET IENS=$$IENS^DILF(.DA)
+26 IF $$GET1^DIQ(811.52,IENS,.01,"I")["AUTTIMM"
SET IMM=1
End DoDot:4
End DoDot:3
End DoDot:2
+27 ;If the finding contains IMMUNIZATIONS and it is not turned on, quit
+28 ;I IMM,+$P(^BQI(90508,1,0),U,16)=0 Q
+29 IF IMM
QUIT
+30 ;If the finding contains ASTHMA and it is not turned on, quit
+31 IF AST
IF +$PIECE(^BQI(90508,1,0),U,17)=0
QUIT
+32 SET RCLIN=$$GET1^DIQ(811.9,EHIEN_",",100,"E")
+33 SET RCLIN=$$LOWER^VALM1(RCLIN)
+34 SET RCAT="EHR Clinical Reminders"
+35 SET CODE="EHR_"_EHIEN
+36 SET HDR="T00050"_CODE
+37 SET RIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
+38 IF RIEN=""
DO FILE^BQIRMDR
QUIT
+39 SET ETLP=0
KILL ^BQI(90506.1,RIEN,4)
+40 IF $GET(^BQI(90506.1,RIEN,4,0))=""
SET ^BQI(90506.1,RIEN,4,0)="^^"
+41 FOR
SET ETLP=$ORDER(^PXD(811.9,EHIEN,1,ETLP))
IF 'ETLP
QUIT
SET ^BQI(90506.1,RIEN,4,ETLP,0)=^PXD(811.9,EHIEN,1,ETLP,0)
+42 DO REA
End DoDot:1
+43 QUIT
+44 ;
EMR(APCHSPAT,CODE) ;EP
+1 NEW EHIEN,RNAME
+2 SET EHIEN=$PIECE(CODE,"_",2)
+3 IF $GET(ERRCNT)=""
SET ERRCNT=0
+4 ;
+5 SET (REMDUE,REMLAST,REMNEXT,RDATA)=""
+6 SET DFN=APCHSPAT
+7 DO MAIN^PXRM(DFN,EHIEN,1,1)
+8 IF $GET(%ZTERZE)'=""
SET ERRCNT=ERRCNT+1
KILL %ZTERZE
QUIT
+9 SET RNAME=$ORDER(^TMP("PXRHM",$JOB,EHIEN,""))
+10 IF RNAME'=""
Begin DoDot:1
+11 SET RDATA=$GET(^TMP("PXRHM",$JOB,EHIEN,RNAME))
End DoDot:1
+12 SET REMDUE=$PIECE(RDATA,U,2)
SET REMLAST=$PIECE(RDATA,U,3)
SET REMNEXT=$PIECE(RDATA,U,1)
+13 ;
+14 DO FIL^BQIRMDR
+15 QUIT
+16 ;
VAR ;EP - Set variables
+1 SET APCHSPAT=DFN
+2 SET APCHSDOB=$PIECE($GET(^DPT(APCHSPAT,0)),U,3)
IF APCHSDOB=""
QUIT
+3 SET APCHSAGE=$$AGE^BQIAGE(APCHSPAT)
+4 SET APCHSEX=$PIECE(^DPT(APCHSPAT,0),U,2)
+5 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)"
+6 SET (APCHSANY,APCHSITM)=0
SET APCHNON=1
SET APCHSURX=""
+7 SET APCHSCKP="S APCHSQIT=1 Q"
+8 SET APCHSBRK="Q"
+9 SET APCHSNPG=0
+10 KILL APCHSTEX
+11 QUIT
+12 ;
REG(APCHSPAT,CODE) ;EP
+1 NEW REG,HIEN,EXEC,RIEN,TAG,CMN,DEN,VAL
+2 SET REG=$PIECE(CODE,"_",2)
+3 SET HIEN=$PIECE(CODE,"_",3)
+4 ;
+5 ; Check if tag is associated with register
+6 SET TAG=$ORDER(^BQI(90506.2,"AD",REG,""))
+7 IF TAG=""
QUIT
+8 SET CMN=$ORDER(^BQI(90506.5,"D",REG,""))
+9 IF CMN=""
QUIT
+10 SET DEN=$GET(^BQI(90506.5,CMN,1))
+11 IF DEN'=""
XECUTE DEN
IF VAL'="Y"
QUIT
+12 ;S RIEN=$O(^BQIREG("C",APCHSPAT,TAG,""))
+13 ;I RIEN="" Q
+14 ; Check if person has an active tag
+15 ;S CSTAT=$P(^BQIREG(RIEN,0),U,3)
+16 ;I '$$ACST^BQITDUTL(CSTAT) Q
+17 ;I CSTAT'="P"&(CSTAT'="A") Q
+18 ;I CSTAT'="P"&(CSTAT'="A") S RQFL=0 D Q:RQFL
+19 ;. I '$$ORG^BQITDUTL(APCHSPAT,REG) S RQFL=1
+20 ;
+21 SET EXEC="D "_$PIECE(^BQI(90507,REG,15,HIEN,0),U,2)
+22 SET EXEC=$TRANSLATE(EXEC,";","^")
+23 SET (REMDUE,REMLAST,REMNEXT)=""
+24 SET DFN=APCHSPAT
+25 XECUTE EXEC
+26 ;
+27 DO FIL^BQIRMDR
+28 QUIT
+29 ;
CMET ;
+1 NEW CIEN
+2 SET SOURCE="Reminders"
SET DEF=0
SET RCLIN=""
+3 SET CIEN=0
+4 FOR
SET CIEN=$ORDER(^BTPW(90621,CIEN))
IF 'CIEN
QUIT
Begin DoDot:1
+5 ; If it is inactive, ignore
+6 IF $PIECE(^BTPW(90621,CIEN,0),U,3)'=""
QUIT
+7 SET TEXT=$PIECE(^BTPW(90621,CIEN,0),U,1)
IF TEXT="N/A"
QUIT
+8 SET RCLIN=$$GET1^DIQ(90621,CIEN_",",.1,"E")
+9 SET RCLIN=$$LOWER^VALM1(RCLIN)
+10 SET RCAT="CMET"
+11 SET CODE="CMET_"_CIEN
+12 SET HDR="T00050"_CODE
+13 SET RIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
+14 IF RIEN=""
DO FILE^BQIRMDR
QUIT
+15 DO REA
End DoDot:1
+16 QUIT
+17 ;
CMT(APCHSPAT,CODE) ;EP
+1 NEW CRIEN
+2 SET CRIEN=$PIECE(CODE,"_",2)
+3 ;
+4 SET (REMDUE,REMLAST,REMNEXT,RDATA)=""
+5 SET DFN=APCHSPAT
+6 SET RDATA=$$EVT^BTPWRMDR(APCHSPAT,CRIEN)
+7 IF RDATA=""
QUIT
+8 SET REMDUE=$PIECE(RDATA,U,7)
SET REMLAST=$PIECE(RDATA,U,5)
SET VISIT=$PIECE(RDATA,U,9)
+9 DO FIL^BQIRMDR
+10 QUIT
+11 ;
VAL(CODE) ;EP - Get the name of a reminder given the CODE
+1 NEW RN,NAME
+2 SET RN=$ORDER(^BQI(90506.1,"B",CODE,""))
IF RN=""
QUIT ""
+3 SET NAME=$PIECE(^BQI(90506.1,RN,0),"^",3)
+4 IF $PIECE(CODE,"_",1)="AUTTIMM"
QUIT ""
+5 IF $PIECE(CODE,"_",1)'="EHR"
IF $PIECE(CODE,"_",1)'="REG"
IF $PIECE(CODE,"_",1)'="CMET"
SET NAME=NAME_" (HS)"
+6 IF $PIECE(CODE,"_",1)="EHR"
SET NAME=NAME_" (EHR)"
+7 IF $PIECE(CODE,"_",1)="REG"
SET NAME=NAME_" (HMS)"
+8 IF $PIECE(CODE,"_",1)="CMET"
SET NAME=NAME_" (CMET)"
+9 IF $PIECE(CODE,"_",1)="IZ"
SET NAME=NAME_" (Forecaster)"
+10 QUIT NAME
