Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQIPTALG

BQIPTALG.m

Go to the documentation of this file. 
  1. BQIPTALG ;PRXM/HC/ALA-Patient Allergies ; 25 Apr 2007  4:52 PM
  1.  ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
  1.  ;
  1.  Q
  1.  ;
  1. EN(DATA,DFN) ;EP -- BQI PATIENT ALLERGIES
  1.  ;Input
  1.  ;  DFN - Patient internal entry number
  1.  ;
  1.  NEW UID,II,HDR,IEN,AGENT,RN,REAC,REC,H,LEN,LENGTH,DLEN,BQID,BI
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIPTALG",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTALG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  NEW ONSET,OBHIS,AGLIST,ALENGTH,ALEN
  1.  S HDR="I00010ALLERGY_IEN^T00064AGENT^T"
  1.  S IEN="",AGLIST=""
  1.  F  S IEN=$O(^GMR(120.8,"B",DFN,IEN)) Q:IEN=""  D
  1.  . I $$GET1^DIQ(120.8,IEN_",",22,"I")=1 Q
  1.  . ;S AGENT=$$GET1^DIQ(120.8,IEN_",",1,"E")
  1.  . S AGENT=$$GET1^DIQ(120.8,IEN_",",.02,"E")
  1.  . S AGLIST=AGLIST_AGENT_";"
  1.  . S ONSET=$$GET1^DIQ(120.8,IEN_",",4,"I")
  1.  . I ONSET S ONSET=$$FMTE^BQIUL1($P(ONSET,"."))
  1.  . S OBHIS=$$GET1^DIQ(120.8,IEN_",",6,"E")
  1.  . ;S RN=0,REAC=$$GET1^DIQ(120.8,IEN_",",.02,"E")
  1.  . ;S REAC=$S(REAC=AGENT:"",1:REAC_";")
  1.  . S RN=0,REAC=""
  1.  . F  S RN=$O(^GMR(120.8,IEN,10,RN)) Q:'RN  D
  1.  .. NEW DA,IENS
  1.  .. S DA(1)=IEN,DA=RN,IENS=$$IENS^DILF(.DA)
  1.  .. S REC=$$GET1^DIQ(120.81,IENS,.01,"E")
  1.  .. I REC="OTHER REACTION" S REC=$$GET1^DIQ(120.81,IENS,1,"E")
  1.  .. S REAC=REAC_REC_";"
  1.  . S REAC=$$TKO^BQIUL1(REAC,";"),LEN=$L(REAC),H(LEN)=IEN
  1.  . S BQID(IEN)=AGENT_U_REAC_U_ONSET_U_OBHIS
  1.  ;
  1.  S AGLIST=$$TKO^BQIUL1(AGLIST,";"),ALENGTH=$L(AGLIST)
  1.  S LENGTH=$O(H(""),-1)
  1.  I +LENGTH=0 S LENGTH=1
  1.  I +ALENGTH=0 S ALENGTH=1
  1.  S DLEN=$E("00000",$L(LENGTH)+1,5)_LENGTH
  1.  S ALEN=$E("00000",$L(ALENGTH)+1,5)_ALENGTH
  1.  S HDR=HDR_DLEN_"REACTION"_U_"D00020DATE_OF_ONSET^T00020OBSERVED/HISTORICAL^T00025ASSESSMENT"
  1.  S @DATA@(II)=HDR_$C(30)
  1.  I '$D(BQID) S II=II+1,$P(@DATA@(II),U,6)=$$ASE(DFN)_$C(30)
  1.  S BI=""
  1.  F  S BI=$O(BQID(BI)) Q:BI=""  S II=II+1,@DATA@(II)=BI_U_BQID(BI)_U_$C(30)
  1.  ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ALG(DFN) ;EP
  1.  NEW IEN,AGLIST,AGENT
  1.  ; Call EHR API to find out no allergy assessment or no known allergies
  1.  D DETAIL^BEHOCACV(.ADATA,DFN)
  1.  I $O(@ADATA@(1))'="" D
  1.  . S IEN="",AGLIST=""
  1.  . F  S IEN=$O(^GMR(120.8,"B",DFN,IEN)) Q:IEN=""  D
  1.  .. I $$GET1^DIQ(120.8,IEN_",",22,"I")=1 Q
  1.  .. S AGENT=$$GET1^DIQ(120.8,IEN_",",.02,"E")
  1.  .. S AGLIST=AGLIST_AGENT_"; "_$C(13)_$C(10)
  1.  ;
  1.  I $O(@ADATA@(1))="" D
  1.  . S AGLIST=$G(@ADATA@(1))
  1.  . S AGLIST=$$LOWER^VALM1(AGLIST)
  1.  . S AGLIST=$TR(AGLIST,".","")
  1.  ;
  1.  Q $$TKO^BQIUL1(AGLIST,"; "_$C(13)_$C(10))
  1.  ;
  1. ASE(DFN) ;EP - Assess allergies
  1.  NEW ADATA,AGLIST
  1.  S AGLIST=""
  1.  ; Call EHR API to find out no allergy assessment or no known allergies
  1.  D DETAIL^BEHOCACV(.ADATA,DFN)
  1.  I $O(@ADATA@(1))="" D
  1.  . S AGLIST=$G(@ADATA@(1))
  1.  . S AGLIST=$$LOWER^VALM1(AGLIST)
  1.  . S AGLIST=$TR(AGLIST,".","")
  1.  Q AGLIST