BQIPTALG ;PRXM/HC/ALA-Patient Allergies ; 25 Apr 2007 4:52 PM
;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
;
Q
;
EN(DATA,DFN) ;EP -- BQI PATIENT ALLERGIES
;Input
; DFN - Patient internal entry number
;
NEW UID,II,HDR,IEN,AGENT,RN,REAC,REC,H,LEN,LENGTH,DLEN,BQID,BI
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTALG",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTALG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW ONSET,OBHIS,AGLIST,ALENGTH,ALEN
S HDR="I00010ALLERGY_IEN^T00064AGENT^T"
S IEN="",AGLIST=""
F S IEN=$O(^GMR(120.8,"B",DFN,IEN)) Q:IEN="" D
. I $$GET1^DIQ(120.8,IEN_",",22,"I")=1 Q
. ;S AGENT=$$GET1^DIQ(120.8,IEN_",",1,"E")
. S AGENT=$$GET1^DIQ(120.8,IEN_",",.02,"E")
. S AGLIST=AGLIST_AGENT_";"
. S ONSET=$$GET1^DIQ(120.8,IEN_",",4,"I")
. I ONSET S ONSET=$$FMTE^BQIUL1($P(ONSET,"."))
. S OBHIS=$$GET1^DIQ(120.8,IEN_",",6,"E")
. ;S RN=0,REAC=$$GET1^DIQ(120.8,IEN_",",.02,"E")
. ;S REAC=$S(REAC=AGENT:"",1:REAC_";")
. S RN=0,REAC=""
. F S RN=$O(^GMR(120.8,IEN,10,RN)) Q:'RN D
.. NEW DA,IENS
.. S DA(1)=IEN,DA=RN,IENS=$$IENS^DILF(.DA)
.. S REC=$$GET1^DIQ(120.81,IENS,.01,"E")
.. I REC="OTHER REACTION" S REC=$$GET1^DIQ(120.81,IENS,1,"E")
.. S REAC=REAC_REC_";"
. S REAC=$$TKO^BQIUL1(REAC,";"),LEN=$L(REAC),H(LEN)=IEN
. S BQID(IEN)=AGENT_U_REAC_U_ONSET_U_OBHIS
;
S AGLIST=$$TKO^BQIUL1(AGLIST,";"),ALENGTH=$L(AGLIST)
S LENGTH=$O(H(""),-1)
I +LENGTH=0 S LENGTH=1
I +ALENGTH=0 S ALENGTH=1
S DLEN=$E("00000",$L(LENGTH)+1,5)_LENGTH
S ALEN=$E("00000",$L(ALENGTH)+1,5)_ALENGTH
S HDR=HDR_DLEN_"REACTION"_U_"D00020DATE_OF_ONSET^T00020OBSERVED/HISTORICAL^T00025ASSESSMENT"
S @DATA@(II)=HDR_$C(30)
I '$D(BQID) S II=II+1,$P(@DATA@(II),U,6)=$$ASE(DFN)_$C(30)
S BI=""
F S BI=$O(BQID(BI)) Q:BI="" S II=II+1,@DATA@(II)=BI_U_BQID(BI)_U_$C(30)
;
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
ALG(DFN) ;EP
NEW IEN,AGLIST,AGENT
; Call EHR API to find out no allergy assessment or no known allergies
D DETAIL^BEHOCACV(.ADATA,DFN)
I $O(@ADATA@(1))'="" D
. S IEN="",AGLIST=""
. F S IEN=$O(^GMR(120.8,"B",DFN,IEN)) Q:IEN="" D
.. I $$GET1^DIQ(120.8,IEN_",",22,"I")=1 Q
.. S AGENT=$$GET1^DIQ(120.8,IEN_",",.02,"E")
.. S AGLIST=AGLIST_AGENT_"; "_$C(13)_$C(10)
;
I $O(@ADATA@(1))="" D
. S AGLIST=$G(@ADATA@(1))
. S AGLIST=$$LOWER^VALM1(AGLIST)
. S AGLIST=$TR(AGLIST,".","")
;
Q $$TKO^BQIUL1(AGLIST,"; "_$C(13)_$C(10))
;
ASE(DFN) ;EP - Assess allergies
NEW ADATA,AGLIST
S AGLIST=""
; Call EHR API to find out no allergy assessment or no known allergies
D DETAIL^BEHOCACV(.ADATA,DFN)
I $O(@ADATA@(1))="" D
. S AGLIST=$G(@ADATA@(1))
. S AGLIST=$$LOWER^VALM1(AGLIST)
. S AGLIST=$TR(AGLIST,".","")
Q AGLIST
BQIPTALG ;PRXM/HC/ALA-Patient Allergies ; 25 Apr 2007 4:52 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
+2 ;
+3 QUIT
+4 ;
EN(DATA,DFN) ;EP -- BQI PATIENT ALLERGIES
+1 ;Input
+2 ; DFN - Patient internal entry number
+3 ;
+4 NEW UID,II,HDR,IEN,AGENT,RN,REAC,REC,H,LEN,LENGTH,DLEN,BQID,BI
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("BQIPTALG",UID))
+7 KILL @DATA
+8 ;
+9 SET II=0
+10 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTALG D UNWIND^%ZTER"
+11 ;
+12 NEW ONSET,OBHIS,AGLIST,ALENGTH,ALEN
+13 SET HDR="I00010ALLERGY_IEN^T00064AGENT^T"
+14 SET IEN=""
SET AGLIST=""
+15 FOR
SET IEN=$ORDER(^GMR(120.8,"B",DFN,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+16 IF $$GET1^DIQ(120.8,IEN_",",22,"I")=1
QUIT
+17 ;S AGENT=$$GET1^DIQ(120.8,IEN_",",1,"E")
+18 SET AGENT=$$GET1^DIQ(120.8,IEN_",",.02,"E")
+19 SET AGLIST=AGLIST_AGENT_";"
+20 SET ONSET=$$GET1^DIQ(120.8,IEN_",",4,"I")
+21 IF ONSET
SET ONSET=$$FMTE^BQIUL1($PIECE(ONSET,"."))
+22 SET OBHIS=$$GET1^DIQ(120.8,IEN_",",6,"E")
+23 ;S RN=0,REAC=$$GET1^DIQ(120.8,IEN_",",.02,"E")
+24 ;S REAC=$S(REAC=AGENT:"",1:REAC_";")
+25 SET RN=0
SET REAC=""
+26 FOR
SET RN=$ORDER(^GMR(120.8,IEN,10,RN))
IF 'RN
QUIT
Begin DoDot:2
+27 NEW DA,IENS
+28 SET DA(1)=IEN
SET DA=RN
SET IENS=$$IENS^DILF(.DA)
+29 SET REC=$$GET1^DIQ(120.81,IENS,.01,"E")
+30 IF REC="OTHER REACTION"
SET REC=$$GET1^DIQ(120.81,IENS,1,"E")
+31 SET REAC=REAC_REC_";"
End DoDot:2
+32 SET REAC=$$TKO^BQIUL1(REAC,";")
SET LEN=$LENGTH(REAC)
SET H(LEN)=IEN
+33 SET BQID(IEN)=AGENT_U_REAC_U_ONSET_U_OBHIS
End DoDot:1
+34 ;
+35 SET AGLIST=$$TKO^BQIUL1(AGLIST,";")
SET ALENGTH=$LENGTH(AGLIST)
+36 SET LENGTH=$ORDER(H(""),-1)
+37 IF +LENGTH=0
SET LENGTH=1
+38 IF +ALENGTH=0
SET ALENGTH=1
+39 SET DLEN=$EXTRACT("00000",$LENGTH(LENGTH)+1,5)_LENGTH
+40 SET ALEN=$EXTRACT("00000",$LENGTH(ALENGTH)+1,5)_ALENGTH
+41 SET HDR=HDR_DLEN_"REACTION"_U_"D00020DATE_OF_ONSET^T00020OBSERVED/HISTORICAL^T00025ASSESSMENT"
+42 SET @DATA@(II)=HDR_$CHAR(30)
+43 IF '$DATA(BQID)
SET II=II+1
SET $PIECE(@DATA@(II),U,6)=$$ASE(DFN)_$CHAR(30)
+44 SET BI=""
+45 FOR
SET BI=$ORDER(BQID(BI))
IF BI=""
QUIT
SET II=II+1
SET @DATA@(II)=BI_U_BQID(BI)_U_$CHAR(30)
+46 ;
+47 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+48 QUIT
+49 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
ALG(DFN) ;EP
+1 NEW IEN,AGLIST,AGENT
+2 ; Call EHR API to find out no allergy assessment or no known allergies
+3 DO DETAIL^BEHOCACV(.ADATA,DFN)
+4 IF $ORDER(@ADATA@(1))'=""
Begin DoDot:1
+5 SET IEN=""
SET AGLIST=""
+6 FOR
SET IEN=$ORDER(^GMR(120.8,"B",DFN,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+7 IF $$GET1^DIQ(120.8,IEN_",",22,"I")=1
QUIT
+8 SET AGENT=$$GET1^DIQ(120.8,IEN_",",.02,"E")
+9 SET AGLIST=AGLIST_AGENT_"; "_$CHAR(13)_$CHAR(10)
End DoDot:2
End DoDot:1
+10 ;
+11 IF $ORDER(@ADATA@(1))=""
Begin DoDot:1
+12 SET AGLIST=$GET(@ADATA@(1))
+13 SET AGLIST=$$LOWER^VALM1(AGLIST)
+14 SET AGLIST=$TRANSLATE(AGLIST,".","")
End DoDot:1
+15 ;
+16 QUIT $$TKO^BQIUL1(AGLIST,"; "_$CHAR(13)_$CHAR(10))
+17 ;
ASE(DFN) ;EP - Assess allergies
+1 NEW ADATA,AGLIST
+2 SET AGLIST=""
+3 ; Call EHR API to find out no allergy assessment or no known allergies
+4 DO DETAIL^BEHOCACV(.ADATA,DFN)
+5 IF $ORDER(@ADATA@(1))=""
Begin DoDot:1
+6 SET AGLIST=$GET(@ADATA@(1))
+7 SET AGLIST=$$LOWER^VALM1(AGLIST)
+8 SET AGLIST=$TRANSLATE(AGLIST,".","")
End DoDot:1
+9 QUIT AGLIST
