BQITRPHS ;APTIV/HC/ALA-Treatment Prompt API for Health Summary ; 28 Feb 2008 3:31 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
EN(BQIDFN,BQIHSM,ARRAY) ; PEP - by patient and each best practice prompt
; Input
; BQIDFN - Patient IEN
; BQIHSM - Treatment Prompt text from File #9001018
; this should match with a category in 90508.5
; ARRAY - Reference that data should be returned in
;
; Get the category IEN
NEW IEN,BQTCT,BQTIEN,BQIDXN,CSTAT,BQIRMK,UID,BK,CT,RESULT
S BQTIEN=$$FIND1^DIC(90508.5,"","BX",BQIHSM,"","","ERROR")
;
K ARRAY
S CT=0
S BQIDXN=$$GET1^DIQ(90508.5,BQTIEN_",",.02,"E")
I '$$ATAG^BQITDUTL(BQIDFN,BQIDXN) Q
;
K BQIRMK
S BK=0,UID=$J
F S BK=$O(^BQI(90508.5,BQTIEN,1,BK)) Q:'BK S BQIRMK(BK)=^BQI(90508.5,BQTIEN,1,BK,0)
I '$$FND^BQITRPPT(BQTIEN,"BQITEST",BQIDFN,.BQIRMK) Q
S ARRAY(0)=1_U_"Patient's active iCare Diagnostic Tag is "_BQIDXN
S CT=CT+1
M ARRAY=BQIRMK
Q
;
APCH ; EP - Tag to be called from Health Summary
NEW APCHSTAT,BQITXT,APCHSCT,APCHSGHR,APCHSL
Q:'$$INAC^APCHSMU(APCHSITI)
; Not a candidate
Q:'$$CVT(APCHSPAT)
S APCHLAST="",APCHNEXT="" K APCHSTEX
I $G(APCHCOLW)="" S APCHCOLW=10
S BQITXT=$P(^APCHSURV(APCHSITI,0),U,1)
D EN(APCHSPAT,BQITXT,.APCHSTEX)
K ^UTILITY($J,"W")
NEW DIWL,DIWR,BQI,X
S DIWR=40,DIWL=1
F BQI=1:1 Q:'$D(APCHSTEX(BQI)) D
. S X=APCHSTEX(BQI)
. D ^DIWP
K APCHSTEX
S X=0 F S X=$O(^UTILITY($J,"W",DIWL,X)) Q:X'=+X S APCHSTEX(X)=^UTILITY($J,"W",DIWL,X,0)
D WRITETP
K ^UTILITY($J,"W")
Q
;
PAT(DFN,ARRAY) ;PEP - By patient and get all best practice prompts
NEW TAG,BQTN,ORD,CT,BQTIEN,BQIRMK,BDT,BI,BK,BN,E,EDT,LCNT,NDESC,PDESC,RES,RESULT,TXT,VSDTM,X
K ARRAY
S TAG=$$CVT(DFN)
I 'TAG S ARRAY(0)="Patient does not have an iCare Diagnostic Tag of CVD" Q
S ARRAY(0)=1_U_"Patient's active iCare Diagnostic Tag is "_$P(TAG,U,2)
I $O(^BQIPAT(DFN,50,0))="" S ARRAY(1)="No CVD Best Practice Prompts on file for this patient."
S BQTIEN=0,CT=0
F S BQTIEN=$O(^BQIPAT(DFN,50,BQTIEN)) Q:'BQTIEN D
. S BN=0,CT=CT+1
. M ARRAY(CT)=^BQIPAT(DFN,50,BQTIEN,1)
Q
;
CVT(DFN) ;EP - Is patient tagged for CVD?
S RESULT=0
S TXT="CVD"
F S TXT=$O(^BQI(90506.2,"B",TXT)) Q:TXT=""!($E(TXT,1,3)'="CVD") D
. I '$$ATAG^BQITDUTL(DFN,TXT) Q
. S RESULT=1_U_TXT_U_$O(^BQI(90506.2,"B",TXT,""))
Q RESULT
;
WRITETP ;EP - write out TP
I $G(APCHSGHR) D Q
.NEW A,B
.S (A,B)=0
.S APCHRVAL(0)="1^"_$P(^APCHSURV(APCHSITI,0),U)
.F S B=$O(APCHSTEX(B)) Q:B'=+B S A=A+1,APCHRVAL(A)=APCHSTEX(B)
I 'APCHSANY D FIRST^APCHSTP Q:$D(APCHSQIT) S APCHSANY=1,APCHSNPG=0
X APCHSCKP Q:$D(APCHSQIT)
I APCHSNPG S APCHSCT=0,APCHSNPG=0
S APCHX=$S($P(^APCHSURV(APCHSITI,0),U,4)]"":$P(^APCHSURV(APCHSITI,0),U,4),1:$P(^APCHSURV(APCHSITI,0),U))
I $D(APCHSTEX)>1 W APCHX,!
I '$D(APCHSTEX) Q
;I $L(APCHX)>28 W !
F APCHSL=1:1 Q:'$D(APCHSTEX(APCHSL))!($D(APCHSQIT)) D
.X APCHSCKP Q:$D(APCHSQIT)
.W ?30,APCHSTEX(APCHSL),!
K APCHSTEX
Q
BQITRPHS ;APTIV/HC/ALA-Treatment Prompt API for Health Summary ; 28 Feb 2008 3:31 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
EN(BQIDFN,BQIHSM,ARRAY) ; PEP - by patient and each best practice prompt
+1 ; Input
+2 ; BQIDFN - Patient IEN
+3 ; BQIHSM - Treatment Prompt text from File #9001018
+4 ; this should match with a category in 90508.5
+5 ; ARRAY - Reference that data should be returned in
+6 ;
+7 ; Get the category IEN
+8 NEW IEN,BQTCT,BQTIEN,BQIDXN,CSTAT,BQIRMK,UID,BK,CT,RESULT
+9 SET BQTIEN=$$FIND1^DIC(90508.5,"","BX",BQIHSM,"","","ERROR")
+10 ;
+11 KILL ARRAY
+12 SET CT=0
+13 SET BQIDXN=$$GET1^DIQ(90508.5,BQTIEN_",",.02,"E")
+14 IF '$$ATAG^BQITDUTL(BQIDFN,BQIDXN)
QUIT
+15 ;
+16 KILL BQIRMK
+17 SET BK=0
SET UID=$JOB
+18 FOR
SET BK=$ORDER(^BQI(90508.5,BQTIEN,1,BK))
IF 'BK
QUIT
SET BQIRMK(BK)=^BQI(90508.5,BQTIEN,1,BK,0)
+19 IF '$$FND^BQITRPPT(BQTIEN,"BQITEST",BQIDFN,.BQIRMK)
QUIT
+20 SET ARRAY(0)=1_U_"Patient's active iCare Diagnostic Tag is "_BQIDXN
+21 SET CT=CT+1
+22 MERGE ARRAY=BQIRMK
+23 QUIT
+24 ;
APCH ; EP - Tag to be called from Health Summary
+1 NEW APCHSTAT,BQITXT,APCHSCT,APCHSGHR,APCHSL
+2 IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+3 ; Not a candidate
+4 IF '$$CVT(APCHSPAT)
QUIT
+5 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+6 IF $GET(APCHCOLW)=""
SET APCHCOLW=10
+7 SET BQITXT=$PIECE(^APCHSURV(APCHSITI,0),U,1)
+8 DO EN(APCHSPAT,BQITXT,.APCHSTEX)
+9 KILL ^UTILITY($JOB,"W")
+10 NEW DIWL,DIWR,BQI,X
+11 SET DIWR=40
SET DIWL=1
+12 FOR BQI=1:1
IF '$DATA(APCHSTEX(BQI))
QUIT
Begin DoDot:1
+13 SET X=APCHSTEX(BQI)
+14 DO ^DIWP
End DoDot:1
+15 KILL APCHSTEX
+16 SET X=0
FOR
SET X=$ORDER(^UTILITY($JOB,"W",DIWL,X))
IF X'=+X
QUIT
SET APCHSTEX(X)=^UTILITY($JOB,"W",DIWL,X,0)
+17 DO WRITETP
+18 KILL ^UTILITY($JOB,"W")
+19 QUIT
+20 ;
PAT(DFN,ARRAY) ;PEP - By patient and get all best practice prompts
+1 NEW TAG,BQTN,ORD,CT,BQTIEN,BQIRMK,BDT,BI,BK,BN,E,EDT,LCNT,NDESC,PDESC,RES,RESULT,TXT,VSDTM,X
+2 KILL ARRAY
+3 SET TAG=$$CVT(DFN)
+4 IF 'TAG
SET ARRAY(0)="Patient does not have an iCare Diagnostic Tag of CVD"
QUIT
+5 SET ARRAY(0)=1_U_"Patient's active iCare Diagnostic Tag is "_$PIECE(TAG,U,2)
+6 IF $ORDER(^BQIPAT(DFN,50,0))=""
SET ARRAY(1)="No CVD Best Practice Prompts on file for this patient."
+7 SET BQTIEN=0
SET CT=0
+8 FOR
SET BQTIEN=$ORDER(^BQIPAT(DFN,50,BQTIEN))
IF 'BQTIEN
QUIT
Begin DoDot:1
+9 SET BN=0
SET CT=CT+1
+10 MERGE ARRAY(CT)=^BQIPAT(DFN,50,BQTIEN,1)
End DoDot:1
+11 QUIT
+12 ;
CVT(DFN) ;EP - Is patient tagged for CVD?
+1 SET RESULT=0
+2 SET TXT="CVD"
+3 FOR
SET TXT=$ORDER(^BQI(90506.2,"B",TXT))
IF TXT=""!($EXTRACT(TXT,1,3)'="CVD")
QUIT
Begin DoDot:1
+4 IF '$$ATAG^BQITDUTL(DFN,TXT)
QUIT
+5 SET RESULT=1_U_TXT_U_$ORDER(^BQI(90506.2,"B",TXT,""))
End DoDot:1
+6 QUIT RESULT
+7 ;
WRITETP ;EP - write out TP
+1 IF $GET(APCHSGHR)
Begin DoDot:1
+2 NEW A,B
+3 SET (A,B)=0
+4 SET APCHRVAL(0)="1^"_$PIECE(^APCHSURV(APCHSITI,0),U)
+5 FOR
SET B=$ORDER(APCHSTEX(B))
IF B'=+B
QUIT
SET A=A+1
SET APCHRVAL(A)=APCHSTEX(B)
End DoDot:1
QUIT
+6 IF 'APCHSANY
DO FIRST^APCHSTP
IF $DATA(APCHSQIT)
QUIT
SET APCHSANY=1
SET APCHSNPG=0
+7 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+8 IF APCHSNPG
SET APCHSCT=0
SET APCHSNPG=0
+9 SET APCHX=$SELECT($PIECE(^APCHSURV(APCHSITI,0),U,4)]"":$PIECE(^APCHSURV(APCHSITI,0),U,4),1:$PIECE(^APCHSURV(APCHSITI,0),U))
+10 IF $DATA(APCHSTEX)>1
WRITE APCHX,!
+11 IF '$DATA(APCHSTEX)
QUIT
+12 ;I $L(APCHX)>28 W !
+13 FOR APCHSL=1:1
IF '$DATA(APCHSTEX(APCHSL))!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+14 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+15 WRITE ?30,APCHSTEX(APCHSL),!
End DoDot:1
+16 KILL APCHSTEX
+17 QUIT
