BEHOART ;MSC/IND/DKM - ART Package Interface ;18-Sep-2014 13:46;DU
;;1.1;BEH COMPONENTS;**045003,045004,045005,045007,045008**;Sep 18, 2007;Build 1
;=================================================================
; RPC: Lock entry for edit
LOCK(DATA,IEN) ;
D:IEN LOCK^CIANBRPC(.DATA,$NA(^GMR(120.8,IEN)),0)
Q
; RPC: Unlock entry
UNLOCK(DATA,IEN) ;
D:IEN LOCK^CIANBRPC(.DATA,$NA(^GMR(120.8,IEN)))
Q
; RPC: Check for duplicate
DUPCHK(DATA,DFN,AGT) ;
S DATA=$$DUPCHK^GMRAOR0(DFN,AGT)>0
Q
; RPC: Sign/verify adverse reaction
SIGN(DATA,IEN,VER) ;
N FDA,ER,ERR,DFN,AGT,N0
I IEN<0 D Q
.S DFN=-IEN
.D FIREEVT(DFN,3,"")
.S DATA=$$HASNKA(DFN)
S N0=$G(^GMR(120.8,IEN,0)),ER=+$G(^("ER")),DFN=+N0,AGT=$P(N0,U,2),DATA="",FDA=$NA(FDA(120.8,IEN_","))
I '$L(N0) S DATA="-1^An unsigned entry for "_AGT_" no longer exists" Q
I ER=1 S DATA="-2^Entry "_AGT_" has been marked as entered in error and cannot be signed" Q
I ER=2,$$DUPCHK^GMRAOR0(DFN,AGT)>0 D Q
.D DEL(.DATA,IEN)
.S:'DATA DATA="-3^A signed entry for "_AGT_" already exists - your entry will be deleted"
I $$CANSIGN(IEN) D
.S @FDA@(15)=1
.S @FDA@(19)=+$P(N0,U,16)
.S:ER @FDA@(22)="@"
I $$CANVERIF(IEN,.VER) D
.S @FDA@(19)=1
.S @FDA@(20)=$$NOW^XLFDT
.S @FDA@(21)=DUZ
.S:ER @FDA@(22)="@"
I $D(FDA)<10 S DATA="-3^You may not sign the "_AGT_" entry" Q
D UPDATE^DIE(,"FDA",,"ERR")
I $G(ERR("DIERR",1)) S DATA=-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1) Q
K ^GMR(120.8,IEN,"ER") ; Remove entered in error node
D FIREEVT(DFN,3,IEN)
;D:'$P(^GMR(120.8,IEN,0),U,16) SENDBULL(IEN)
Q
; RPC: Return list of entries to be signed/verified
SIGNLIST(DATA,DFN,VER) ;
N FLG,IEN,PFX,X,Y
S (FLG,IEN)=0,VER=$G(VER)
F S IEN=$O(^GMR(120.8,"B",DFN,IEN)) Q:'IEN D
.S X=$G(^GMR(120.8,IEN,0)),Y=+$G(^("ER"))
.Q:+X'=DFN
.Q:Y=1
.S FLG=1
.I $$CANSIGN(IEN) S PFX=""
.E I '$P(X,U,12)!'$$CANVERIF(IEN,VER) Q
.E S PFX="Verify "
.S DATA(IEN)=IEN_U_PFX_"Adverse Reaction to "_$P(X,U,2)
I 'FLG D
.S X=$G(^GMR(120.86,DFN,0))
.Q:$P(X,U,3)'=DUZ
.Q:$P(X,U,4)
.S DATA(0)=-DFN_U_"No Known Allergies"
Q
; RPC: Load specified ART entry for editing
LOAD(DATA,IEN,NOLCK) ;
N X,X0,LP,LP2,IN,IIEN,X1,IENS,DC,ZZ,Z1
K DATA
I IEN<0 D Q
.S DATA(0)=0_U_$$HASNKA(-IEN)
I IEN>0 D Q:$D(DATA(-1))
.I '$D(^GMR(120.8,IEN,0)) S DATA(-1)="-1^This entry no longer exists." Q
.Q:$G(NOLCK)
.D LOCK(.X,IEN)
.S:'X DATA(-1)="-1^Another user is editing this entry."
S X0=$G(^GMR(120.8,IEN,0))
S DATA(1)=1_U_$P(X0,U,16)
S DC=0,ZZ="" S DC=$O(^GMR(120.8,IEN,3,DC))
I +DC D
.S Z1=$P($G(^GMR(120.8,IEN,3,DC,0)),U,1)
.S ZZ=$P($G(^PS(50.605,+Z1,0)),U,1)
S X=$P(X0,U,3),DATA(2)=2_U_+X_U_$P(X0,U,2)_U_$P(X,";",2)_U_ZZ
S DATA(3)=3_U_$P(X0,U,20)
S DATA(10)=10_U_$P(X0,U,14)
S DATA(14)=14_U_$P(X0,U,12)
S X=$O(^GMR(120.85,"C",IEN,0))
I X D
.S X0=^GMR(120.85,X,0)
.S DATA(4)=4_U_1
.S DATA(5)=5_U_$P(X0,U,13)_U_$$GET1^DIQ(200,$P(X0,U,13),.01)
.S DATA(6)=6_U_+X0
.S DATA(7)=7_U_$P(X0,U,14)
I $P($G(^GMR(120.8,IEN,9999999.11)),U,1)'="" D
.S DATA(11)=11_U_$P($G(^GMR(120.8,IEN,9999999.11)),U,1)
.S DATA(11)=DATA(11)_U_$P($G(^BEHOAR(90460.05,$P(DATA(11),U,2),0)),U,1)
I $P($G(^GMR(120.8,IEN,9999999.11)),U,2)'="" D
.S DATA(13)=13_U_$P($G(^GMR(120.8,IEN,9999999.11)),U,2)
.S DATA(13)=DATA(13)_U_$P($G(^BEHOAR(90460.06,$P(DATA(13),U,2),0)),U,1)
S LP=0
F S LP=$O(^GMR(120.8,IEN,10,LP)) Q:'LP S X=+^(LP,0) D
.S IENS=LP_","_IEN
.S DATA(8,LP)=8_U_X_U_$$GET1^DIQ(120.83,X,.01)_U_$P($G(^GMR(120.8,IEN,10,LP,0)),U,4)_U_$$GET1^DIQ(120.81,IENS,3)_U_$P($G(^GMR(120.8,IEN,10,LP,9999999.11)),U,1)_U_$$GET1^DIQ(120.81,IENS,9999999.11)
;IHS/MSC/MGH Check for inactive data
S IN=9999999 S IN=$O(^GMR(120.8,IEN,9999999.12,IN),-1) Q:IN="" D
.S X1=$G(^GMR(120.8,IEN,9999999.12,IN,0))
.S DATA(12)=12_U_$P(X1,U,1)_U_$P(X1,U,2)_U_$P(X1,U,3)_U_$P(X1,U,4)_U_$P(X1,U,5)
S LP=$$GETCMNT(IEN),LP2=0
F S LP2=$O(^GMR(120.8,IEN,26,LP,2,LP2)) Q:'LP2 S DATA(9,LP2)=9_U_^(LP2,0)
Q
; RPC: Delete ART entry
DEL(DATA,IEN) ;
N GMR0,DIK,DA
S GMR0=$G(^GMR(120.8,IEN,0)),DATA=""
I '$L(GMR0) S DATA="-1^Entry not found" Q
I $P(GMR0,U,16) S DATA="-1^Cannot delete a verified entry" Q
I $P(GMR0,U,12) S DATA="-1^Cannot delete a signed entry" Q
S DIK=$$ROOT^DILFD(120.8),DA=IEN
D ^DIK
D FIREEVT(+GMR0,2,IEN)
Q
; RPC: Save ART entry
SAVE(DATA,IEN,DFN,VAL,ACTION) ;
N FDA,FDA2,TAG,FLD,ERR,RIEN,NEW,AGNT,NOW,NKA,MIEN,SIG,CANVER
S NOW=$$NOW^XLFDT
S ACTION=$G(ACTION)
S NKA=0
I ACTION="E" D EIE^BEHOARMU(.DATA,IEN,DFN,.VAL) Q
I ACTION="I" D INACT^BEHOARMU(.DATA,IEN,DFN,.VAL) Q
I ACTION="R" D REACT^BEHOARMU(.DATA,IEN,DFN,.VAL) Q
I ACTION="A" D ASSESS^BEHOARMU(.DATA,IEN,DFN,.VAL) Q
I ACTION="U" D REASSESS^BEHOARMU(.DATA,IEN,DFN,.VAL) Q
S:$G(IEN) RIEN=$O(^GMR(120.85,"C",IEN,0))
S RIEN=$S($G(RIEN):RIEN_",",1:"+3,")
S NEW='$G(IEN),IEN=$S(NEW:"+1,",1:IEN_",")
S TAG=""
F S TAG=$O(VAL(TAG)) Q:'$L(TAG) D
.S VAL=VAL(TAG)
.D @TAG
;I FDA(120.8,IEN,1)="" S DATA="-1^Free text entries can no longer be stored"
I $D(FDA(120.8)) D
.S:NEW FDA(120.8,IEN,.01)=DFN
.S:NEW FDA(120.8,IEN,4)=$$NOW^XLFDT
.S:NEW FDA(120.8,IEN,5)=DUZ
.S:NEW FDA(120.8,IEN,15)=0
.S:NEW FDA(120.8,IEN,22)=2
D UPDATE^DIE(,"FDA","IEN","ERR")
S DATA=$S(NKA:$G(IEN(2)),NEW:$G(IEN(1)),1:+IEN)
Q:'DATA
;Add the last modified data patch 8
;p11 - rearranged calls to prevent UPDSF from being called for NKA
I 'NKA D
.S MIEN="+1,"_DATA_","
.S FDA(120.899999914,MIEN,.01)=$$NOW^XLFDT
.S FDA(120.899999914,MIEN,.02)=DUZ
.D UPDATE^DIE(,"FDA","IEN","ERR")
.I $D(FDA2) D
..S FDA2(120.85,RIEN,.02)=DFN
..S FDA2(120.85,RIEN,.03)=DATA
.E S:$E(RIEN)'="+" FDA2(120.85,RIEN,.01)="@"
.D:$D(FDA2) UPDATE^DIE(,"FDA2")
.D UPDSF(DATA,.AGNT)
.;Patch 13 add RxNorm and UNI codes if available
.D RXNORM^GMRAZRXU(DATA)
D CKIN^BEHOARMU(DFN)
D FIREEVT(DFN,'NEW,DATA)
Q:NKA
S CANVER=$$HASKEY^BEHOUSCX("GMRA-ALLERGY VERIFY")
;D:$$CANSIGN(DATA) SNDALR(DATA,1) ;EHR P10
D:$$CANSIGN(DATA) SIGN(.SIG,DATA,CANVER) ;AUTOSIGN
Q
GMRAAGNT N X
S AGNT=$$CODE(VAL)
I '$L(AGNT) D
.S AGNT=$P($P(VAL,U,3),",")
.I AGNT[$C(34) S AGNT=$P(AGNT,$C(34))
.S:$L(AGNT) AGNT=+VAL_";"_AGNT_","
S FDA(120.8,IEN,.02)=$P(VAL,U,2)
S FDA(120.8,IEN,1)=AGNT
Q
GMRACMTS N CMNT
S CMNT=$S(NEW:0,1:$$GETCMNT(+IEN))
S:'CMNT CMNT="+4"
S CMNT=CMNT_","_IEN
S FDA(120.826,CMNT,.01)=NOW
S FDA(120.826,CMNT,1)=DUZ
S FDA(120.826,CMNT,2)=$NA(VAL(TAG))
Q
GMRANATR S FDA(120.8,IEN,3.1)=$P(VAL,U)
Q
GMRAMECH ; no longer used
Q
GMRANKA N AIEN
S NKA=1
I $D(^GMR(120.86,DFN,0)) S AIEN=DFN_","
E S AIEN="+2,",FDA(120.86,AIEN,.01)=DFN
S IEN(2)=DFN
S FDA(120.86,AIEN,1)=0
S FDA(120.86,AIEN,2)=DUZ
S FDA(120.86,AIEN,3)=NOW
S FDA(120.86,AIEN,9999999.01)=160244002
Q
GMRAOBHX S FDA(120.8,IEN,6)=$S(VAL:"o",1:"h")
Q
;Source of information added MSC/IHS/MGH
GMRASRC N SRC,GMRASRC
S GMRASRC=$G(VAL("GMRASRC"))
I '$P(GMRASRC,U) S SRC=$O(^BEHOAR(90460.05,"B",$P(GMRASRC,U,2),"")) Q:SRC="" D
.S FDA(120.8,IEN,9999999.11)=SRC
E S FDA(120.8,IEN,9999999.11)=+GMRASRC
Q
GMRASNO ;Snomed event type added MSC/IHS/MGH
N SNOMED,SNO,MECH,SNOTXT
S SNOMED=$G(VAL("GMRASNO"))
I '$P(SNOMED,U) S SNO=$O(^BEHOAR(90460.06,"B",$P(SNOMED,U,2),"")) Q:SNO="" D
.S FDA(120.8,IEN,9999999.13)=SNO,SNOMED=SNO
E S FDA(120.8,IEN,9999999.13)=+SNOMED
S SNOTXT=$P($G(^BEHOAR(90460.06,+SNOMED,0)),U,1)
S MECH=$S(SNOTXT="DRUG ALLERGY":"A",SNOTXT="FOOD ALLERGY":"A",SNOTXT="DRUG INTOLERANCE":"P",1:"U")
S FDA(120.8,IEN,17)=MECH
Q
GMRAOBSV S FDA2(120.85,RIEN,.5)=$P(VAL,U)
Q
GMRARDAT S FDA2(120.85,RIEN,.01)=+VAL
Q
GMRASEVR S FDA2(120.85,RIEN,14.5)=VAL
Q
GMRASYMP N LP,IEN2,X,XCL,SRC,SRIEN,V
F LP=0:0 S LP=$O(VAL(TAG,LP)) Q:'LP D
.S V=VAL(TAG,LP)
.S X=+V
.I 'NEW D Q:IEN2
..S IEN2=$O(^GMR(120.8,+IEN,10,"B",X,0))
..S:IEN2 XCL(IEN2)=""
.S IEN2="+"_(LP+10)_","_IEN
.S FDA(120.81,IEN2,.01)=X
.S FDA(120.81,IEN2,2)=DUZ
.S FDA(120.81,IEN2,3)=$P(V,U,3) ;Sign/Symptom date/time
.S SRC=$P(V,U,5)
.I +SRC>0 S FDA(120.81,IEN2,9999999.11)=SRC
.E I SRC'="" D
..S SRIEN=$O(^BEHOAR(90460.05,"B",SRC,"")) Q:SRIEN="" D
...S FDA(120.81,IEN2,9999999.11)=SRIEN
D DELSF(120.81,IEN,.XCL)
Q
DELSF(SFN,IEN,XCL) ;
N DIK,DA,LP,GBL,IEN2
S IEN2=","_IEN,DIK=$$ROOT^DILFD(SFN,IEN2),GBL=$$ROOT^DILFD(SFN,IEN2,1),DA=0
F S DA=$O(@GBL@(DA)),DA(1)=+IEN Q:'DA D:'$D(XCL(DA)) ^DIK
Q
; Check NKA/Update status
HASNKA(DFN,CREATE) ;
N LP,AL,FDA,IEN
S (AL,LP)=0
F S LP=$O(^GMR(120.8,"B",DFN,LP)) Q:'LP D Q:AL
.S:'$G(^GMR(120.8,LP,"ER")) AL=1
I $D(^GMR(120.86,DFN,0)) Q:$P(^(0),U,2)=AL 'AL S IEN=DFN_","
E I '$G(CREATE) Q 'AL
E D
.S IEN="+1,",IEN(1)=DFN
.S FDA(120.86,IEN,.01)=DFN
.S FDA(120.86,IEN,2)=DUZ
.S FDA(120.86,IEN,3)=$$NOW^XLFDT
S FDA(120.86,IEN,1)=AL
I AL=1 S FDA(120.86,IEN,9999999.01)="@"
I AL=0 S FDA(120.86,IEN,9999999.01)=160244002
D UPDATE^DIE(,"FDA","IEN")
Q 'AL
; Return last subfile entry for user comment
GETCMNT(IEN) ;
N LP
S LP=$C(1)
F S LP=$O(^GMR(120.8,IEN,26,LP),-1) Q:'LP Q:$P(^(LP,0),U,2)=DUZ
Q +LP
; Update ingredient and class subfiles
UPDSF(GMRAPA,GMRAAR) ;
I $G(GMRAAR) D
.F X=120.802,120.803 D DELSF(X,+GMRAPA_",")
.D:$G(GMRAAR) EN1^GMRAOR9
Q
; Send a verification request bulletin
SENDBULL(GMRAPA) ;
N GMRANAM,GMRALOC,GMRASSN,GMRAREC,GMRAOTH,GMRATXT,GMRACNT
N XMB,XMY,XMTEXT,DFN,APSPHRN,X
S GMRAPA(0)=$G(^GMR(120.8,+GMRAPA,0))
D:$L(GMRAPA(0)) EN1^GMRAVAB
Q
; Check if user can sign entry
CANSIGN(IEN) ;
N X,SIGN,Z,REACT
S REACT=""
S X=$G(^GMR(120.8,+IEN,0))
;I $P(X,U,5)=DUZ&'$P(X,U,12)
S Z=$O(^GMR(120.8,IEN,9999999.12,$C(0)),-1) I +Z D
.S REACT=$P($G(^GMR(120.8,IEN,9999999.12,Z,0)),U,5)
Q ($P(X,U,5)=DUZ!(REACT=DUZ))&('$P(X,U,12))
; Check if entry is candidate for autoverification
CANVERIF(IEN,VER) ;
N GMRASITE
S IEN=+IEN,IEN(0)=$G(^GMR(120.8,IEN,0))
Q:$P(IEN(0),U,16) 0
Q:$G(VER) 1
Q $$VFY^GMRASIGN(.IEN)
; Fire a GMRA event
; ACTION = 0: New entry; 1: Edit; 2: Delete; 3: Sign
FIREEVT(DFN,ACTION,DATA) ;
N X
I $$HASNKA(DFN,ACTION=3)
D QUEUE^CIANBEVT("GMRA."_DFN,ACTION_U_DATA)
S X=$$FIND1^DIC(101,,"BX","GMRA ALLERGY UPDATE")_";ORD(101,"
D:X EN^XQOR ;Process protocols hanging off this protocol
Q
; Returns agent text as variable pointer if found
; EHR 13 added drug ingredient to the list
CODE(X) N D,DIC,TRD,Y
N AGNT
S AGNT=$P($P(X,U,3),",")
I AGNT="GMRD(120.82" Q +X_";"_AGNT_","
I AGNT="PSNDF(50.6" Q +X_";"_AGNT_","
I AGNT="PS(50.605" Q +X_";"_AGNT_","
I AGNT="PS(50.416" Q +X_";"_AGNT_","
S TRD=$$TTOG^PSNAPIS($P(X,U,2),.TRD)
Q:TRD $O(TRD(0))_$TR($$NDFREF^GMRAOR,U,";")
Q ""
; Update alerts for current user
UPDALR N AID,GMRAIEN,DFN,CANVER,MGRP,TYP,SGN,DEL,N0
S AID="BEHOAR",CANVER=$$HASKEY^BEHOUSCX("GMRA-ALLERGY VERIFY")
I CANVER F TYP="DRUG","FOOD","OTHER" S:$$ISMBR^BEHOXQ("GMRA VERIFY "_TYP_" ALLERGY",DUZ) TYP($E(TYP))=""
; Remove alerts no longer applicable
F S AID=$O(^XTV(8992,"AXQA",AID)) Q:$E(AID,1,6)'="BEHOAR" D
.N EIE
.S GMRAIEN=+$P(AID,",",2),N0=$G(^GMR(120.8,GMRAIEN,0)),TYP=$P(N0,U,20),SGN=AID["SIGN"
.S EIE=$P($G(^GMR(120.8,GMRAIEN,"ER")),U,1)=1
.S DEL=$S(AID'[".":2,'$L(N0):2,$P(N0,U,16):2,EIE:2,'$D(^XTV(8992,"AXQA",AID,DUZ)):0,$$RCVALR(GMRAIEN,SGN,.TYP):0,1:1)
.D BEHDEL^BEHOXQ(AID):DEL=2,BEHDEL^BEHOXQ(AID,1):DEL=1
; Add verification alerts for this user
Q:$D(TYP)<10
S DFN=0
F S DFN=$O(^GMR(120.8,"AVER",DFN)) Q:'DFN D
.S GMRAIEN=0
.F S GMRAIEN=$O(^GMR(120.8,"AVER",DFN,GMRAIEN)) Q:'GMRAIEN D
..S TYP=$P($G(^GMR(120.8,GMRAIEN,0)),U,20)
..D:$$RCVALR(GMRAIEN,0,.TYP) SNDALR(GMRAIEN,0)
Q
; Send alert for user
SNDALR(GMRAIEN,SGN) ;
N N0,AID,XQA,XQAMSG,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLG,XQAARCH,XQASURO,XQASUPV,XQATEXT
S AID="BEHOAR."_$S(SGN:"SIGN",1:"VERIFY")_","_GMRAIEN,N0=$G(^GMR(120.8,GMRAIEN,0))
Q:'$L(N0)
Q:$D(^XTV(8992,"AXQAN",AID,DUZ))
S XQAMSG="Adverse reaction "_$S(SGN:"signature",1:"verification")_" required for "_$P(N0,U,2)
S XQADATA="DFN="_DFN_"^PRI=2^INF=0^TYP="_$S(SGN:"SIGN",1:"VERIFY")_"^SRV=BEHARTENTRY.ARTENTRY"
S XQAID=AID
S XQA(DUZ)=""
D SETUP^XQALERT
Q
; Return true if user should receive alert for this allergy
RCVALR(GMRAIEN,SGN,TYP) ;
N LP,OK
I SGN S OK=$$CANSIGN(GMRAIEN)
E D
.Q:$D(TYP)<10
.F LP=1:1:$L(TYP) I $D(TYP($E(TYP,LP))) S OK=1 Q
Q $G(OK)
ING(DATA,GMRAPA) ;Return
N GMRAINGR,GMRACLAS,X,Y,CNT,CNT2
S DATA=$$TMPGBL^CIAVMRPC,CNT=0
F GMRAINGR=0:0 S GMRAINGR=$O(^GMR(120.8,GMRAPA,2,GMRAINGR)) Q:'+GMRAINGR D
.S X=$S($D(^GMR(120.8,GMRAPA,2,GMRAINGR,0)):^(0),1:"")
.I +X>0 S Y=$S($D(^PS(50.416,+X,0)):^(0),1:"") I $P(Y,U)'="" S GMRAINGR($P(Y,U),+X)=Y
F GMRACLAS=0:0 S GMRACLAS=$O(^GMR(120.8,GMRAPA,3,GMRACLAS)) Q:'+GMRACLAS D
.S X=$S($D(^GMR(120.8,GMRAPA,3,GMRACLAS,0)):^(0),1:"")
.I +X>0 S Y=$S($D(^PS(50.605,+X,0)):^(0),1:"") I $P(Y,U)'="" S GMRACLAS($P(Y,U),+X)=Y
S CNT=0
I $D(GMRACLAS)>10 D
.S Y="" F S Y=$O(GMRACLAS(Y)) Q:Y="" D
..F X=0:0 S X=$O(GMRACLAS(Y,X)) Q:X'>0 D
...S CNT=CNT+1
...I CNT=1 S @DATA@(CNT)="DRUG CLASSES: "_$P(GMRACLAS(Y,X),U,2)
...E S @DATA@(CNT)=" "_$P(GMRACLAS(Y,X),U,2)
I $D(GMRAINGR)>10 D
.S CNT=CNT+1 S @DATA@(CNT)=""
.S CNT2=0
.S Y="" F S Y=$O(GMRAINGR(Y)) Q:Y="" D
..F X=0:0 S X=$O(GMRAINGR(Y,X)) Q:X'>0 D
...S CNT=CNT+1,CNT2=CNT2+1
...I CNT2=1 S @DATA@(CNT)=" INGREDIENTS: "_$P(GMRAINGR(Y,X),U,1)
...E S @DATA@(CNT)=" "_$P(GMRAINGR(Y,X),U,1)
Q
;Return status of EIE Comment prompt
AEIECMT(DATA) ;EP-
N SITE,IEN
S SITE=$O(^GMRD(120.84,"B",""))
I SITE="" S DATA=0 Q
S IEN=$O(^GMRD(120.84,"B",SITE,0))
I 'IEN S DATA=0 Q
S DATA=+$P($G(^GMRD(120.84,IEN,0)),U,11)
Q
BEHOART ;MSC/IND/DKM - ART Package Interface ;18-Sep-2014 13:46;DU
+1 ;;1.1;BEH COMPONENTS;**045003,045004,045005,045007,045008**;Sep 18, 2007;Build 1
+2 ;=================================================================
+3 ; RPC: Lock entry for edit
LOCK(DATA,IEN) ;
+1 IF IEN
DO LOCK^CIANBRPC(.DATA,$NAME(^GMR(120.8,IEN)),0)
+2 QUIT
+3 ; RPC: Unlock entry
UNLOCK(DATA,IEN) ;
+1 IF IEN
DO LOCK^CIANBRPC(.DATA,$NAME(^GMR(120.8,IEN)))
+2 QUIT
+3 ; RPC: Check for duplicate
DUPCHK(DATA,DFN,AGT) ;
+1 SET DATA=$$DUPCHK^GMRAOR0(DFN,AGT)>0
+2 QUIT
+3 ; RPC: Sign/verify adverse reaction
SIGN(DATA,IEN,VER) ;
+1 NEW FDA,ER,ERR,DFN,AGT,N0
+2 IF IEN<0
Begin DoDot:1
+3 SET DFN=-IEN
+4 DO FIREEVT(DFN,3,"")
+5 SET DATA=$$HASNKA(DFN)
End DoDot:1
QUIT
+6 SET N0=$GET(^GMR(120.8,IEN,0))
SET ER=+$GET(^("ER"))
SET DFN=+N0
SET AGT=$PIECE(N0,U,2)
SET DATA=""
SET FDA=$NAME(FDA(120.8,IEN_","))
+7 IF '$LENGTH(N0)
SET DATA="-1^An unsigned entry for "_AGT_" no longer exists"
QUIT
+8 IF ER=1
SET DATA="-2^Entry "_AGT_" has been marked as entered in error and cannot be signed"
QUIT
+9 IF ER=2
IF $$DUPCHK^GMRAOR0(DFN,AGT)>0
Begin DoDot:1
+10 DO DEL(.DATA,IEN)
+11 IF 'DATA
SET DATA="-3^A signed entry for "_AGT_" already exists - your entry will be deleted"
End DoDot:1
QUIT
+12 IF $$CANSIGN(IEN)
Begin DoDot:1
+13 SET @FDA@(15)=1
+14 SET @FDA@(19)=+$PIECE(N0,U,16)
+15 IF ER
SET @FDA@(22)="@"
End DoDot:1
+16 IF $$CANVERIF(IEN,.VER)
Begin DoDot:1
+17 SET @FDA@(19)=1
+18 SET @FDA@(20)=$$NOW^XLFDT
+19 SET @FDA@(21)=DUZ
+20 IF ER
SET @FDA@(22)="@"
End DoDot:1
+21 IF $DATA(FDA)<10
SET DATA="-3^You may not sign the "_AGT_" entry"
QUIT
+22 DO UPDATE^DIE(,"FDA",,"ERR")
+23 IF $GET(ERR("DIERR",1))
SET DATA=-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1)
QUIT
+24 ; Remove entered in error node
KILL ^GMR(120.8,IEN,"ER")
+25 DO FIREEVT(DFN,3,IEN)
+26 ;D:'$P(^GMR(120.8,IEN,0),U,16) SENDBULL(IEN)
+27 QUIT
+28 ; RPC: Return list of entries to be signed/verified
SIGNLIST(DATA,DFN,VER) ;
+1 NEW FLG,IEN,PFX,X,Y
+2 SET (FLG,IEN)=0
SET VER=$GET(VER)
+3 FOR
SET IEN=$ORDER(^GMR(120.8,"B",DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+4 SET X=$GET(^GMR(120.8,IEN,0))
SET Y=+$GET(^("ER"))
+5 IF +X'=DFN
QUIT
+6 IF Y=1
QUIT
+7 SET FLG=1
+8 IF $$CANSIGN(IEN)
SET PFX=""
+9 IF '$TEST
IF '$PIECE(X,U,12)!'$$CANVERIF(IEN,VER)
QUIT
+10 IF '$TEST
SET PFX="Verify "
+11 SET DATA(IEN)=IEN_U_PFX_"Adverse Reaction to "_$PIECE(X,U,2)
End DoDot:1
+12 IF 'FLG
Begin DoDot:1
+13 SET X=$GET(^GMR(120.86,DFN,0))
+14 IF $PIECE(X,U,3)'=DUZ
QUIT
+15 IF $PIECE(X,U,4)
QUIT
+16 SET DATA(0)=-DFN_U_"No Known Allergies"
End DoDot:1
+17 QUIT
+18 ; RPC: Load specified ART entry for editing
LOAD(DATA,IEN,NOLCK) ;
+1 NEW X,X0,LP,LP2,IN,IIEN,X1,IENS,DC,ZZ,Z1
+2 KILL DATA
+3 IF IEN<0
Begin DoDot:1
+4 SET DATA(0)=0_U_$$HASNKA(-IEN)
End DoDot:1
QUIT
+5 IF IEN>0
Begin DoDot:1
+6 IF '$DATA(^GMR(120.8,IEN,0))
SET DATA(-1)="-1^This entry no longer exists."
QUIT
+7 IF $GET(NOLCK)
QUIT
+8 DO LOCK(.X,IEN)
+9 IF 'X
SET DATA(-1)="-1^Another user is editing this entry."
End DoDot:1
IF $DATA(DATA(-1))
QUIT
+10 SET X0=$GET(^GMR(120.8,IEN,0))
+11 SET DATA(1)=1_U_$PIECE(X0,U,16)
+12 SET DC=0
SET ZZ=""
SET DC=$ORDER(^GMR(120.8,IEN,3,DC))
+13 IF +DC
Begin DoDot:1
+14 SET Z1=$PIECE($GET(^GMR(120.8,IEN,3,DC,0)),U,1)
+15 SET ZZ=$PIECE($GET(^PS(50.605,+Z1,0)),U,1)
End DoDot:1
+16 SET X=$PIECE(X0,U,3)
SET DATA(2)=2_U_+X_U_$PIECE(X0,U,2)_U_$PIECE(X,";",2)_U_ZZ
+17 SET DATA(3)=3_U_$PIECE(X0,U,20)
+18 SET DATA(10)=10_U_$PIECE(X0,U,14)
+19 SET DATA(14)=14_U_$PIECE(X0,U,12)
+20 SET X=$ORDER(^GMR(120.85,"C",IEN,0))
+21 IF X
Begin DoDot:1
+22 SET X0=^GMR(120.85,X,0)
+23 SET DATA(4)=4_U_1
+24 SET DATA(5)=5_U_$PIECE(X0,U,13)_U_$$GET1^DIQ(200,$PIECE(X0,U,13),.01)
+25 SET DATA(6)=6_U_+X0
+26 SET DATA(7)=7_U_$PIECE(X0,U,14)
End DoDot:1
+27 IF $PIECE($GET(^GMR(120.8,IEN,9999999.11)),U,1)'=""
Begin DoDot:1
+28 SET DATA(11)=11_U_$PIECE($GET(^GMR(120.8,IEN,9999999.11)),U,1)
+29 SET DATA(11)=DATA(11)_U_$PIECE($GET(^BEHOAR(90460.05,$PIECE(DATA(11),U,2),0)),U,1)
End DoDot:1
+30 IF $PIECE($GET(^GMR(120.8,IEN,9999999.11)),U,2)'=""
Begin DoDot:1
+31 SET DATA(13)=13_U_$PIECE($GET(^GMR(120.8,IEN,9999999.11)),U,2)
+32 SET DATA(13)=DATA(13)_U_$PIECE($GET(^BEHOAR(90460.06,$PIECE(DATA(13),U,2),0)),U,1)
End DoDot:1
+33 SET LP=0
+34 FOR
SET LP=$ORDER(^GMR(120.8,IEN,10,LP))
IF 'LP
QUIT
SET X=+^(LP,0)
Begin DoDot:1
+35 SET IENS=LP_","_IEN
+36 SET DATA(8,LP)=8_U_X_U_$$GET1^DIQ(120.83,X,.01)_U_$PIECE($GET(^GMR(120.8,IEN,10,LP,0)),U,4)_U_$$GET1^DIQ(120.81,IENS,3)_U_$PIECE($GET(^GMR(120.8,IEN,10,LP,9999999.11)),U,1)_U_$$GET1^DIQ(120.81,IENS,9999999.11)
End DoDot:1
+37 ;IHS/MSC/MGH Check for inactive data
+38 SET IN=9999999
SET IN=$ORDER(^GMR(120.8,IEN,9999999.12,IN),-1)
IF IN=""
QUIT
Begin DoDot:1
+39 SET X1=$GET(^GMR(120.8,IEN,9999999.12,IN,0))
+40 SET DATA(12)=12_U_$PIECE(X1,U,1)_U_$PIECE(X1,U,2)_U_$PIECE(X1,U,3)_U_$PIECE(X1,U,4)_U_$PIECE(X1,U,5)
End DoDot:1
+41 SET LP=$$GETCMNT(IEN)
SET LP2=0
+42 FOR
SET LP2=$ORDER(^GMR(120.8,IEN,26,LP,2,LP2))
IF 'LP2
QUIT
SET DATA(9,LP2)=9_U_^(LP2,0)
+43 QUIT
+44 ; RPC: Delete ART entry
DEL(DATA,IEN) ;
+1 NEW GMR0,DIK,DA
+2 SET GMR0=$GET(^GMR(120.8,IEN,0))
SET DATA=""
+3 IF '$LENGTH(GMR0)
SET DATA="-1^Entry not found"
QUIT
+4 IF $PIECE(GMR0,U,16)
SET DATA="-1^Cannot delete a verified entry"
QUIT
+5 IF $PIECE(GMR0,U,12)
SET DATA="-1^Cannot delete a signed entry"
QUIT
+6 SET DIK=$$ROOT^DILFD(120.8)
SET DA=IEN
+7 DO ^DIK
+8 DO FIREEVT(+GMR0,2,IEN)
+9 QUIT
+10 ; RPC: Save ART entry
SAVE(DATA,IEN,DFN,VAL,ACTION) ;
+1 NEW FDA,FDA2,TAG,FLD,ERR,RIEN,NEW,AGNT,NOW,NKA,MIEN,SIG,CANVER
+2 SET NOW=$$NOW^XLFDT
+3 SET ACTION=$GET(ACTION)
+4 SET NKA=0
+5 IF ACTION="E"
DO EIE^BEHOARMU(.DATA,IEN,DFN,.VAL)
QUIT
+6 IF ACTION="I"
DO INACT^BEHOARMU(.DATA,IEN,DFN,.VAL)
QUIT
+7 IF ACTION="R"
DO REACT^BEHOARMU(.DATA,IEN,DFN,.VAL)
QUIT
+8 IF ACTION="A"
DO ASSESS^BEHOARMU(.DATA,IEN,DFN,.VAL)
QUIT
+9 IF ACTION="U"
DO REASSESS^BEHOARMU(.DATA,IEN,DFN,.VAL)
QUIT
+10 IF $GET(IEN)
SET RIEN=$ORDER(^GMR(120.85,"C",IEN,0))
+11 SET RIEN=$SELECT($GET(RIEN):RIEN_",",1:"+3,")
+12 SET NEW='$GET(IEN)
SET IEN=$SELECT(NEW:"+1,",1:IEN_",")
+13 SET TAG=""
+14 FOR
SET TAG=$ORDER(VAL(TAG))
IF '$LENGTH(TAG)
QUIT
Begin DoDot:1
+15 SET VAL=VAL(TAG)
+16 DO @TAG
End DoDot:1
+17 ;I FDA(120.8,IEN,1)="" S DATA="-1^Free text entries can no longer be stored"
+18 IF $DATA(FDA(120.8))
Begin DoDot:1
+19 IF NEW
SET FDA(120.8,IEN,.01)=DFN
+20 IF NEW
SET FDA(120.8,IEN,4)=$$NOW^XLFDT
+21 IF NEW
SET FDA(120.8,IEN,5)=DUZ
+22 IF NEW
SET FDA(120.8,IEN,15)=0
+23 IF NEW
SET FDA(120.8,IEN,22)=2
End DoDot:1
+24 DO UPDATE^DIE(,"FDA","IEN","ERR")
+25 SET DATA=$SELECT(NKA:$GET(IEN(2)),NEW:$GET(IEN(1)),1:+IEN)
+26 IF 'DATA
QUIT
+27 ;Add the last modified data patch 8
+28 ;p11 - rearranged calls to prevent UPDSF from being called for NKA
+29 IF 'NKA
Begin DoDot:1
+30 SET MIEN="+1,"_DATA_","
+31 SET FDA(120.899999914,MIEN,.01)=$$NOW^XLFDT
+32 SET FDA(120.899999914,MIEN,.02)=DUZ
+33 DO UPDATE^DIE(,"FDA","IEN","ERR")
+34 IF $DATA(FDA2)
Begin DoDot:2
+35 SET FDA2(120.85,RIEN,.02)=DFN
+36 SET FDA2(120.85,RIEN,.03)=DATA
End DoDot:2
+37 IF '$TEST
IF $EXTRACT(RIEN)'="+"
SET FDA2(120.85,RIEN,.01)="@"
+38 IF $DATA(FDA2)
DO UPDATE^DIE(,"FDA2")
+39 DO UPDSF(DATA,.AGNT)
+40 ;Patch 13 add RxNorm and UNI codes if available
+41 DO RXNORM^GMRAZRXU(DATA)
End DoDot:1
+42 DO CKIN^BEHOARMU(DFN)
+43 DO FIREEVT(DFN,'NEW,DATA)
+44 IF NKA
QUIT
+45 SET CANVER=$$HASKEY^BEHOUSCX("GMRA-ALLERGY VERIFY")
+46 ;D:$$CANSIGN(DATA) SNDALR(DATA,1) ;EHR P10
+47 ;AUTOSIGN
IF $$CANSIGN(DATA)
DO SIGN(.SIG,DATA,CANVER)
+48 QUIT
GMRAAGNT NEW X
+1 SET AGNT=$$CODE(VAL)
+2 IF '$LENGTH(AGNT)
Begin DoDot:1
+3 SET AGNT=$PIECE($PIECE(VAL,U,3),",")
+4 IF AGNT[$CHAR(34)
SET AGNT=$PIECE(AGNT,$CHAR(34))
+5 IF $LENGTH(AGNT)
SET AGNT=+VAL_";"_AGNT_","
End DoDot:1
+6 SET FDA(120.8,IEN,.02)=$PIECE(VAL,U,2)
+7 SET FDA(120.8,IEN,1)=AGNT
+8 QUIT
GMRACMTS NEW CMNT
+1 SET CMNT=$SELECT(NEW:0,1:$$GETCMNT(+IEN))
+2 IF 'CMNT
SET CMNT="+4"
+3 SET CMNT=CMNT_","_IEN
+4 SET FDA(120.826,CMNT,.01)=NOW
+5 SET FDA(120.826,CMNT,1)=DUZ
+6 SET FDA(120.826,CMNT,2)=$NAME(VAL(TAG))
+7 QUIT
GMRANATR SET FDA(120.8,IEN,3.1)=$PIECE(VAL,U)
+1 QUIT
GMRAMECH ; no longer used
+1 QUIT
GMRANKA NEW AIEN
+1 SET NKA=1
+2 IF $DATA(^GMR(120.86,DFN,0))
SET AIEN=DFN_","
+3 IF '$TEST
SET AIEN="+2,"
SET FDA(120.86,AIEN,.01)=DFN
+4 SET IEN(2)=DFN
+5 SET FDA(120.86,AIEN,1)=0
+6 SET FDA(120.86,AIEN,2)=DUZ
+7 SET FDA(120.86,AIEN,3)=NOW
+8 SET FDA(120.86,AIEN,9999999.01)=160244002
+9 QUIT
GMRAOBHX SET FDA(120.8,IEN,6)=$SELECT(VAL:"o",1:"h")
+1 QUIT
+2 ;Source of information added MSC/IHS/MGH
GMRASRC NEW SRC,GMRASRC
+1 SET GMRASRC=$GET(VAL("GMRASRC"))
+2 IF '$PIECE(GMRASRC,U)
SET SRC=$ORDER(^BEHOAR(90460.05,"B",$PIECE(GMRASRC,U,2),""))
IF SRC=""
QUIT
Begin DoDot:1
+3 SET FDA(120.8,IEN,9999999.11)=SRC
End DoDot:1
+4 IF '$TEST
SET FDA(120.8,IEN,9999999.11)=+GMRASRC
+5 QUIT
GMRASNO ;Snomed event type added MSC/IHS/MGH
+1 NEW SNOMED,SNO,MECH,SNOTXT
+2 SET SNOMED=$GET(VAL("GMRASNO"))
+3 IF '$PIECE(SNOMED,U)
SET SNO=$ORDER(^BEHOAR(90460.06,"B",$PIECE(SNOMED,U,2),""))
IF SNO=""
QUIT
Begin DoDot:1
+4 SET FDA(120.8,IEN,9999999.13)=SNO
SET SNOMED=SNO
End DoDot:1
+5 IF '$TEST
SET FDA(120.8,IEN,9999999.13)=+SNOMED
+6 SET SNOTXT=$PIECE($GET(^BEHOAR(90460.06,+SNOMED,0)),U,1)
+7 SET MECH=$SELECT(SNOTXT="DRUG ALLERGY":"A",SNOTXT="FOOD ALLERGY":"A",SNOTXT="DRUG INTOLERANCE":"P",1:"U")
+8 SET FDA(120.8,IEN,17)=MECH
+9 QUIT
GMRAOBSV SET FDA2(120.85,RIEN,.5)=$PIECE(VAL,U)
+1 QUIT
GMRARDAT SET FDA2(120.85,RIEN,.01)=+VAL
+1 QUIT
GMRASEVR SET FDA2(120.85,RIEN,14.5)=VAL
+1 QUIT
GMRASYMP NEW LP,IEN2,X,XCL,SRC,SRIEN,V
+1 FOR LP=0:0
SET LP=$ORDER(VAL(TAG,LP))
IF 'LP
QUIT
Begin DoDot:1
+2 SET V=VAL(TAG,LP)
+3 SET X=+V
+4 IF 'NEW
Begin DoDot:2
+5 SET IEN2=$ORDER(^GMR(120.8,+IEN,10,"B",X,0))
+6 IF IEN2
SET XCL(IEN2)=""
End DoDot:2
IF IEN2
QUIT
+7 SET IEN2="+"_(LP+10)_","_IEN
+8 SET FDA(120.81,IEN2,.01)=X
+9 SET FDA(120.81,IEN2,2)=DUZ
+10 ;Sign/Symptom date/time
SET FDA(120.81,IEN2,3)=$PIECE(V,U,3)
+11 SET SRC=$PIECE(V,U,5)
+12 IF +SRC>0
SET FDA(120.81,IEN2,9999999.11)=SRC
+13 IF '$TEST
IF SRC'=""
Begin DoDot:2
+14 SET SRIEN=$ORDER(^BEHOAR(90460.05,"B",SRC,""))
IF SRIEN=""
QUIT
Begin DoDot:3
+15 SET FDA(120.81,IEN2,9999999.11)=SRIEN
End DoDot:3
End DoDot:2
End DoDot:1
+16 DO DELSF(120.81,IEN,.XCL)
+17 QUIT
DELSF(SFN,IEN,XCL) ;
+1 NEW DIK,DA,LP,GBL,IEN2
+2 SET IEN2=","_IEN
SET DIK=$$ROOT^DILFD(SFN,IEN2)
SET GBL=$$ROOT^DILFD(SFN,IEN2,1)
SET DA=0
+3 FOR
SET DA=$ORDER(@GBL@(DA))
SET DA(1)=+IEN
IF 'DA
QUIT
IF '$DATA(XCL(DA))
DO ^DIK
+4 QUIT
+5 ; Check NKA/Update status
HASNKA(DFN,CREATE) ;
+1 NEW LP,AL,FDA,IEN
+2 SET (AL,LP)=0
+3 FOR
SET LP=$ORDER(^GMR(120.8,"B",DFN,LP))
IF 'LP
QUIT
Begin DoDot:1
+4 IF '$GET(^GMR(120.8,LP,"ER"))
SET AL=1
End DoDot:1
IF AL
QUIT
+5 IF $DATA(^GMR(120.86,DFN,0))
IF $PIECE(^(0),U,2)=AL
QUIT 'AL
SET IEN=DFN_","
+6 IF '$TEST
IF '$GET(CREATE)
QUIT 'AL
+7 IF '$TEST
Begin DoDot:1
+8 SET IEN="+1,"
SET IEN(1)=DFN
+9 SET FDA(120.86,IEN,.01)=DFN
+10 SET FDA(120.86,IEN,2)=DUZ
+11 SET FDA(120.86,IEN,3)=$$NOW^XLFDT
End DoDot:1
+12 SET FDA(120.86,IEN,1)=AL
+13 IF AL=1
SET FDA(120.86,IEN,9999999.01)="@"
+14 IF AL=0
SET FDA(120.86,IEN,9999999.01)=160244002
+15 DO UPDATE^DIE(,"FDA","IEN")
+16 QUIT 'AL
+17 ; Return last subfile entry for user comment
GETCMNT(IEN) ;
+1 NEW LP
+2 SET LP=$CHAR(1)
+3 FOR
SET LP=$ORDER(^GMR(120.8,IEN,26,LP),-1)
IF 'LP
QUIT
IF $PIECE(^(LP,0),U,2)=DUZ
QUIT
+4 QUIT +LP
+5 ; Update ingredient and class subfiles
UPDSF(GMRAPA,GMRAAR) ;
+1 IF $GET(GMRAAR)
Begin DoDot:1
+2 FOR X=120.802,120.803
DO DELSF(X,+GMRAPA_",")
+3 IF $GET(GMRAAR)
DO EN1^GMRAOR9
End DoDot:1
+4 QUIT
+5 ; Send a verification request bulletin
SENDBULL(GMRAPA) ;
+1 NEW GMRANAM,GMRALOC,GMRASSN,GMRAREC,GMRAOTH,GMRATXT,GMRACNT
+2 NEW XMB,XMY,XMTEXT,DFN,APSPHRN,X
+3 SET GMRAPA(0)=$GET(^GMR(120.8,+GMRAPA,0))
+4 IF $LENGTH(GMRAPA(0))
DO EN1^GMRAVAB
+5 QUIT
+6 ; Check if user can sign entry
CANSIGN(IEN) ;
+1 NEW X,SIGN,Z,REACT
+2 SET REACT=""
+3 SET X=$GET(^GMR(120.8,+IEN,0))
+4 ;I $P(X,U,5)=DUZ&'$P(X,U,12)
+5 SET Z=$ORDER(^GMR(120.8,IEN,9999999.12,$CHAR(0)),-1)
IF +Z
Begin DoDot:1
+6 SET REACT=$PIECE($GET(^GMR(120.8,IEN,9999999.12,Z,0)),U,5)
End DoDot:1
+7 QUIT ($PIECE(X,U,5)=DUZ!(REACT=DUZ))&('$PIECE(X,U,12))
+8 ; Check if entry is candidate for autoverification
CANVERIF(IEN,VER) ;
+1 NEW GMRASITE
+2 SET IEN=+IEN
SET IEN(0)=$GET(^GMR(120.8,IEN,0))
+3 IF $PIECE(IEN(0),U,16)
QUIT 0
+4 IF $GET(VER)
QUIT 1
+5 QUIT $$VFY^GMRASIGN(.IEN)
+6 ; Fire a GMRA event
+7 ; ACTION = 0: New entry; 1: Edit; 2: Delete; 3: Sign
FIREEVT(DFN,ACTION,DATA) ;
+1 NEW X
+2 IF $$HASNKA(DFN,ACTION=3)
+3 DO QUEUE^CIANBEVT("GMRA."_DFN,ACTION_U_DATA)
+4 SET X=$$FIND1^DIC(101,,"BX","GMRA ALLERGY UPDATE")_";ORD(101,"
+5 ;Process protocols hanging off this protocol
IF X
DO EN^XQOR
+6 QUIT
+7 ; Returns agent text as variable pointer if found
+8 ; EHR 13 added drug ingredient to the list
CODE(X) NEW D,DIC,TRD,Y
+1 NEW AGNT
+2 SET AGNT=$PIECE($PIECE(X,U,3),",")
+3 IF AGNT="GMRD(120.82"
QUIT +X_";"_AGNT_","
+4 IF AGNT="PSNDF(50.6"
QUIT +X_";"_AGNT_","
+5 IF AGNT="PS(50.605"
QUIT +X_";"_AGNT_","
+6 IF AGNT="PS(50.416"
QUIT +X_";"_AGNT_","
+7 SET TRD=$$TTOG^PSNAPIS($PIECE(X,U,2),.TRD)
+8 IF TRD
QUIT $ORDER(TRD(0))_$TRANSLATE($$NDFREF^GMRAOR,U,";")
+9 QUIT ""
+10 ; Update alerts for current user
UPDALR NEW AID,GMRAIEN,DFN,CANVER,MGRP,TYP,SGN,DEL,N0
+1 SET AID="BEHOAR"
SET CANVER=$$HASKEY^BEHOUSCX("GMRA-ALLERGY VERIFY")
+2 IF CANVER
FOR TYP="DRUG","FOOD","OTHER"
IF $$ISMBR^BEHOXQ("GMRA VERIFY "_TYP_" ALLERGY",DUZ)
SET TYP($EXTRACT(TYP))=""
+3 ; Remove alerts no longer applicable
+4 FOR
SET AID=$ORDER(^XTV(8992,"AXQA",AID))
IF $EXTRACT(AID,1,6)'="BEHOAR"
QUIT
Begin DoDot:1
+5 NEW EIE
+6 SET GMRAIEN=+$PIECE(AID,",",2)
SET N0=$GET(^GMR(120.8,GMRAIEN,0))
SET TYP=$PIECE(N0,U,20)
SET SGN=AID["SIGN"
+7 SET EIE=$PIECE($GET(^GMR(120.8,GMRAIEN,"ER")),U,1)=1
+8 SET DEL=$SELECT(AID'[".":2,'$LENGTH(N0):2,$PIECE(N0,U,16):2,EIE:2,'$DATA(^XTV(8992,"AXQA",AID,DUZ)):0,$$RCVALR(GMRAIEN,SGN,.TYP):0,1:1)
+9 IF DEL=2
DO BEHDEL^BEHOXQ(AID)
IF DEL=1
DO BEHDEL^BEHOXQ(AID,1)
End DoDot:1
+10 ; Add verification alerts for this user
+11 IF $DATA(TYP)<10
QUIT
+12 SET DFN=0
+13 FOR
SET DFN=$ORDER(^GMR(120.8,"AVER",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+14 SET GMRAIEN=0
+15 FOR
SET GMRAIEN=$ORDER(^GMR(120.8,"AVER",DFN,GMRAIEN))
IF 'GMRAIEN
QUIT
Begin DoDot:2
+16 SET TYP=$PIECE($GET(^GMR(120.8,GMRAIEN,0)),U,20)
+17 IF $$RCVALR(GMRAIEN,0,.TYP)
DO SNDALR(GMRAIEN,0)
End DoDot:2
End DoDot:1
+18 QUIT
+19 ; Send alert for user
SNDALR(GMRAIEN,SGN) ;
+1 NEW N0,AID,XQA,XQAMSG,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLG,XQAARCH,XQASURO,XQASUPV,XQATEXT
+2 SET AID="BEHOAR."_$SELECT(SGN:"SIGN",1:"VERIFY")_","_GMRAIEN
SET N0=$GET(^GMR(120.8,GMRAIEN,0))
+3 IF '$LENGTH(N0)
QUIT
+4 IF $DATA(^XTV(8992,"AXQAN",AID,DUZ))
QUIT
+5 SET XQAMSG="Adverse reaction "_$SELECT(SGN:"signature",1:"verification")_" required for "_$PIECE(N0,U,2)
+6 SET XQADATA="DFN="_DFN_"^PRI=2^INF=0^TYP="_$SELECT(SGN:"SIGN",1:"VERIFY")_"^SRV=BEHARTENTRY.ARTENTRY"
+7 SET XQAID=AID
+8 SET XQA(DUZ)=""
+9 DO SETUP^XQALERT
+10 QUIT
+11 ; Return true if user should receive alert for this allergy
RCVALR(GMRAIEN,SGN,TYP) ;
+1 NEW LP,OK
+2 IF SGN
SET OK=$$CANSIGN(GMRAIEN)
+3 IF '$TEST
Begin DoDot:1
+4 IF $DATA(TYP)<10
QUIT
+5 FOR LP=1:1:$LENGTH(TYP)
IF $DATA(TYP($EXTRACT(TYP,LP)))
SET OK=1
QUIT
End DoDot:1
+6 QUIT $GET(OK)
ING(DATA,GMRAPA) ;Return
+1 NEW GMRAINGR,GMRACLAS,X,Y,CNT,CNT2
+2 SET DATA=$$TMPGBL^CIAVMRPC
SET CNT=0
+3 FOR GMRAINGR=0:0
SET GMRAINGR=$ORDER(^GMR(120.8,GMRAPA,2,GMRAINGR))
IF '+GMRAINGR
QUIT
Begin DoDot:1
+4 SET X=$SELECT($DATA(^GMR(120.8,GMRAPA,2,GMRAINGR,0)):^(0),1:"")
+5 IF +X>0
SET Y=$SELECT($DATA(^PS(50.416,+X,0)):^(0),1:"")
IF $PIECE(Y,U)'=""
SET GMRAINGR($PIECE(Y,U),+X)=Y
End DoDot:1
+6 FOR GMRACLAS=0:0
SET GMRACLAS=$ORDER(^GMR(120.8,GMRAPA,3,GMRACLAS))
IF '+GMRACLAS
QUIT
Begin DoDot:1
+7 SET X=$SELECT($DATA(^GMR(120.8,GMRAPA,3,GMRACLAS,0)):^(0),1:"")
+8 IF +X>0
SET Y=$SELECT($DATA(^PS(50.605,+X,0)):^(0),1:"")
IF $PIECE(Y,U)'=""
SET GMRACLAS($PIECE(Y,U),+X)=Y
End DoDot:1
+9 SET CNT=0
+10 IF $DATA(GMRACLAS)>10
Begin DoDot:1
+11 SET Y=""
FOR
SET Y=$ORDER(GMRACLAS(Y))
IF Y=""
QUIT
Begin DoDot:2
+12 FOR X=0:0
SET X=$ORDER(GMRACLAS(Y,X))
IF X'>0
QUIT
Begin DoDot:3
+13 SET CNT=CNT+1
+14 IF CNT=1
SET @DATA@(CNT)="DRUG CLASSES: "_$PIECE(GMRACLAS(Y,X),U,2)
+15 IF '$TEST
SET @DATA@(CNT)=" "_$PIECE(GMRACLAS(Y,X),U,2)
End DoDot:3
End DoDot:2
End DoDot:1
+16 IF $DATA(GMRAINGR)>10
Begin DoDot:1
+17 SET CNT=CNT+1
SET @DATA@(CNT)=""
+18 SET CNT2=0
+19 SET Y=""
FOR
SET Y=$ORDER(GMRAINGR(Y))
IF Y=""
QUIT
Begin DoDot:2
+20 FOR X=0:0
SET X=$ORDER(GMRAINGR(Y,X))
IF X'>0
QUIT
Begin DoDot:3
+21 SET CNT=CNT+1
SET CNT2=CNT2+1
+22 IF CNT2=1
SET @DATA@(CNT)=" INGREDIENTS: "_$PIECE(GMRAINGR(Y,X),U,1)
+23 IF '$TEST
SET @DATA@(CNT)=" "_$PIECE(GMRAINGR(Y,X),U,1)
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;Return status of EIE Comment prompt
AEIECMT(DATA) ;EP-
+1 NEW SITE,IEN
+2 SET SITE=$ORDER(^GMRD(120.84,"B",""))
+3 IF SITE=""
SET DATA=0
QUIT
+4 SET IEN=$ORDER(^GMRD(120.84,"B",SITE,0))
+5 IF 'IEN
SET DATA=0
QUIT
+6 SET DATA=+$PIECE($GET(^GMRD(120.84,IEN,0)),U,11)
+7 QUIT
