ORWDAL32 ; SLC/REV - Allergy calls to support windows ;Apr 21, 2022@08:43:40
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,190,195,233,243,539,405**;Dec 17, 1997;Build 211
;
; DBIA #4531 NAME^PSN50P41
; DBIA #4543 C^PSN50P65
; DBIA #2531 $$B^PSNAPIS, $$T^PSNAPIS
; DBIA #2574 $$TGTOG^PSNAPIS
; DBIA #4829 ALL^PSN5067
; DBIA #4683 GETREC^GMRAGUI
; DBIA #4682 EIE^GMRAGUI1, NKA^GMRAGUI1, UPDATE^GMRAGUI1
; DBIA #4374 $$SENDREQ^GMRAPES0
; DBIA #4684 SITE^GMRAUTL
; DBIA #1234 Direct global read of ^DIC(3.1
;
DEF(LST) ; Get dialog data for allergies
N ILST,I,X S ILST=0
S LST($$NXT)="~Allergy Types" D ALLGYTYP
S LST($$NXT)="~Reactions" D ALLGYTYP
S LST($$NXT)="~Nature of Reaction" D NATREACT
S LST($$NXT)="~Top Ten" D TOPTEN
S LST($$NXT)="~Observ/Hist" D OBSHIST
S LST($$NXT)="~Severity" D SEVERITY
Q
GMRASITE(ORY) ;Return GMRA Site Params
N GMRASITE
D SITE^GMRAUTL
S ORY=$G(^GMRD(120.84,GMRASITE,0))
Q
TOPTEN ; Get top ten symptoms from Allergy Site Parameters file
N X0,I,CNT,GMRASITE S I=0,X0="",CNT=0 ;233
D SITE^GMRAUTL ;233
F S I=$O(^GMRD(120.84,GMRASITE,1,I)),CNT=CNT+1 Q:+I=0!(CNT>10) D ;233
. S X0=^GMRD(120.84,GMRASITE,1,I,0) Q:'$D(^GMRD(120.83,X0)) Q:$P(^GMRD(120.83,X0,0),"^")="OTHER REACTION" ;233 Don't send this entry
. ;233 Don't send if inactive term
. I $L($T(SCREEN^XTID)) Q:$$SCREEN^XTID(120.83,.01,X0_",")
. S LST($$NXT)="i"_X0_U_$P($G(^GMRD(120.83,X0,0)),U,1)
Q
ALLSRCH(Y,X) ; Return list of partial matches ; CHANGED TO PRODUCE TREEVIEW IN GUI
N ORX,ROOT,XP,CNT,ORFILE,ORSRC,ORIEN,ORREAX S ORIEN=0,CNT=0,ORSRC=0,ORFILE=""
S ORX=X,X=$$UP^XLFSTR(X)
F ROOT="^GMRD(120.82,""B"")","^GMRD(120.82,""D"")",$$B^PSNAPIS,$$T^PSNAPIS,"^PSDRUG(""B"")","^PSDRUG(""C"")","^PS(50.416,""P"")","^PS(50.605,""C"")" D
. S ORSRC=$G(ORSRC)+1,ORFILE=$P(ROOT,",",1)_")",ORSRC(ORSRC)=$P($T(FILENAME+ORSRC),";;",2)
. I (ORSRC'=2),(ORSRC'=6) S CNT=CNT+1,Y(CNT)=ORSRC_U_ORSRC(ORSRC)_U_U_U_"TOP"_U_"+"
. I ORSRC=1!(ORSRC=2) D
.. I $D(@ROOT@(X)) D
... I ORSRC=1,X="OTHER ALLERGY/ADVERSE REACTION" Q ;don't send this entry
... S ORIEN=$O(@ROOT@(X,0))
... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.82,.01,ORIEN_",") Q ;233 Is term active?
... I ORSRC=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_X_">"_ROOT
... I ORSRC'=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_X_ROOT
... S Y(CNT)=Y(CNT)_U_$P($G(^GMRD(120.82,+Y(CNT),0)),U,2)_U_$S(ORSRC=2:1,1:ORSRC)
.. S XP=X F S XP=$O(@ROOT@(XP)) Q:XP="" Q:$E(XP,1,$L(X))'=X D
... I ORSRC=1,XP="OTHER ALLERGY/ADVERSE REACTION" Q ;don't send this entry
... S ORIEN=$O(@ROOT@(XP,0))
... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.82,.01,ORIEN_",") Q ;233 Is term active?
... I ORSRC=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_XP_">"_ROOT ; partial matches
... I ORSRC'=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_XP_ROOT
... S Y(CNT)=Y(CNT)_U_$P($G(^GMRD(120.82,+Y(CNT),0)),U,2)_U_$S(ORSRC=2:1,1:ORSRC)
. I (ORSRC>2),(ORSRC'=4),(ORSRC'=5),(ORSRC'=6) D
.. N CODE,LIST,VAL,NAME
.. S CODE=$S(ORSRC=3:"S VAL=$$TGTOG2^PSNAPIS(X,.LIST)",ORSRC=4:"D TRDNAME(X,.LIST)",ORSRC=7:"D INGSRCH(X,.LIST)",ORSRC=8:"D CLASRCH(X,.LIST)",1:"") Q:'$L(CODE)
.. X CODE I $D(LIST) S ORIEN=0 F S ORIEN=$O(LIST(ORIEN)) Q:'ORIEN D
... S NAME=$P(LIST(ORIEN),U,2)
... Q:$E($P(LIST(ORIEN),U,2),1,$L(X))'=X
... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID($S(ORSRC=3:50.6,(ORSRC=4):50.6,ORSRC=7:50.416,ORSRC=8:50.605,1:0),.01,ORIEN_",") Q
... S CNT=CNT+1,Y(CNT)=ORIEN_U_NAME_ROOT_U_"D"_U_ORSRC
. I ORSRC=4 D
.. N CODE,LIST,VAL,NAME
.. S CODE="D TRDNAME(X,.LIST)"
.. X CODE I $D(LIST) S ORIEN=0 F S ORIEN=$O(LIST(ORIEN)) Q:'ORIEN D
... S NAME=$P(LIST(ORIEN),U,2)
... Q:$E($P(LIST(ORIEN),U,2),1,$L(X))'=X
... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(50.6,.01,+LIST(ORIEN)_",") Q
... S CNT=CNT+1,Y(CNT)=+LIST(ORIEN)_U_NAME_ROOT_U_"D"_U_ORSRC
Q
FILENAME ; Display text of filenames for search treeview
;;VA Allergies File
;;VA Allergies File (Synonyms) SPACER ONLY - NOT DISPLAYED
;;National Drug File - Generic Drug Name
;;National Drug file - Trade Name
;;Local Drug File
;;Local Drug File (Synonyms) SPACER ONLY - NOT DISPLAYED
;;Drug Ingredients File
;;VA Drug Class File
;;
NATREACT ; Get the NATURE OF REACTION types
;Removing "R^Adverse Reaction" from choices below until we can add it as a choice in the nature of reaction/mechanism file
F X="A^Allergy","P^Pharmacological","U^Unknown" D
. S LST($$NXT)="i"_X
Q
ALLGYTYP ; Get the allergy types
F X="D^Drug","F^Food","O^Other","DF^Drug,Food","DO^Drug,Other","FO^Food,Other","DFO^Drug,Food,Other" D
. S LST($$NXT)="i"_X
Q
OBSHIST ; Observed or historical
F X="o^Observed","h^Historical" D
. S LST($$NXT)="i"_X
Q
SEVERITY ; Severity
F X="3^Severe","2^Moderate","1^Mild" D
. S LST($$NXT)="i"_X
Q
SYMPTOMS(Y,FROM,DIR) ; Return a subset of symptoms
; .Return Array, Starting Text, Direction
N I,IEN,CNT,X,NAME,SUB,SYN S I=0,CNT=44 ;233
K ^TMP($J,"SIGNS") ;233
;The following lines were added in 233. Now accounts for synonyms
M ^TMP($J,"SIGNS","B")=^GMRD(120.83,"B") ;233
S SYN="" F S SYN=$O(^GMRD(120.83,"D",SYN)) Q:SYN="" S SUB=0 F S SUB=$O(^GMRD(120.83,"D",SYN,SUB)) Q:'+SUB D ;233
.S NAME=$P(^GMRD(120.83,SUB,0),U) S ^TMP($J,"SIGNS","B",(SYN_$C(9)_"<"_NAME_">"_U_NAME),SUB)="" ;233
F Q:I'<CNT S FROM=$O(^TMP($J,"SIGNS","B",FROM),DIR) Q:FROM="" D ;233
. I FROM="OTHER REACTION" Q ;Don't send this entry
. S IEN=0 F S IEN=$O(^TMP($J,"SIGNS","B",FROM,IEN)) Q:'IEN D ;233
. . I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.83,.01,IEN_",") Q ;233 Is term active
. . S I=I+1
. . S Y(I)=IEN_U_FROM
Q
NXT() ; Increment index of LST
S ILST=ILST+1
Q ILST
EDITLOAD(Y,ORALIEN) ; Load an allergy/adverse reaction for editing
Q:+$G(ORALIEN)=0
N ORNODE,I
S ORNODE=$NAME(^TMP("GMRA",$J)),I=0
;following patch check is made via GUI RPC call to ORWU PATCH instead
;I '$$PATCH^XPDUTL("GMRA*4.0*21") S @ORNODE@(0)="-1^Not yet implemented",Y=ORNODE Q
D GETREC^GMRAGUI(ORALIEN,ORNODE)
S Y=ORNODE
Q
EDITSAVE(ORY,ORALIEN,ORDFN,OREDITED) ; Save Edit/Add of an allergy/adverse reaction
;following patch check is made via GUI RPC call to ORWU PATCH instead
;I '$$PATCH^XPDUTL("GMRA*4.0*21") S Y="-1^Not yet implemented" Q
N ORNODE
S ORNODE=$NAME(^TMP("GMRA",$J))
K @ORNODE M @ORNODE=OREDITED
S ORY=0
I $G(@ORNODE@("GMRAERR"))="YES" D EIE^GMRAGUI1(ORALIEN,ORDFN,ORNODE) Q ;Handle entered in error
I $G(@ORNODE@("GMRANKA"))="YES" D NKA^GMRAGUI1 Q
D UPDATE^GMRAGUI1(ORALIEN,ORDFN,ORNODE) Q ;Add/edit reactions
Q
SENDBULL(Y,ORDUZ,ORDFN,ORTEXT,ORCMTS) ; Send bulletin if user attempts free-text entry
I '$D(ORCMTS) D
. S Y=$$SENDREQ^GMRAPES0(ORDUZ,ORDFN,ORTEXT)
E D
. S Y=$$SENDREQ^GMRAPES0(ORDUZ,ORDFN,ORTEXT,.ORCMTS)
Q
INGSRCH(NAME,LIST) ;
K ^TMP($J,"ORWDAL32")
D NAME^PSN50P41(NAME,"ORWDAL32")
I $D(^TMP($J,"ORWDAL32","P")) D
. N I S I="" F S I=$O(^TMP($J,"ORWDAL32","P",I)) Q:I="" D
.. N J S J=0 F S J=$O(^TMP($J,"ORWDAL32","P",I,J)) Q:'J S LIST(J)=J_U_I
K ^TMP($J,"ORWDAL32")
Q
CLASRCH(NAME,LIST) ;
K ^TMP($J,"ORWDAL32")
D C^PSN50P65(,NAME,"ORWDAL32")
I $D(^TMP($J,"ORWDAL32","C")) D
. N I S I="" F S I=$O(^TMP($J,"ORWDAL32","C",I)) Q:I="" D
.. N J S J=0 F S J=$O(^TMP($J,"ORWDAL32","C",I,J)) Q:'J S LIST(J)=J_U_$G(^TMP($J,"ORWDAL32",J,1))
K ^TMP($J,"ORWDAL32")
Q
TRDNAME(NAME,LIST) ;
K ^TMP($J,"ORWDAL32")
D ALL^PSN5067(,NAME,,"ORWDAL32")
I $D(^TMP($J,"ORWDAL32","B")) D
. N I S I="" F S I=$O(^TMP($J,"ORWDAL32","B",I)) Q:I="" D
.. N J,K S J=$O(^TMP($J,"ORWDAL32","B",I,0)) Q:'J S K=$$TGTOG^PSNAPIS(I),LIST(J)=K_U_$G(^TMP($J,"ORWDAL32",J,4))
K ^TMP($J,"ORWDAL32")
Q
CHKMEDS(LST,ORDFN,GMRAGNT) ;Check a newly entered allergy against existing orders
N ALST,L,MED,M,AGYLST,ORD,ENT,DFN,ATTEND,MDA,MEDD,MDARRAY,MDARRAY2,FILLID,STATUS,FID,AGYTXT
S LST=0
S STATUS="^DISCONTINUED^DISCONTINUED (EDIT)^CANCELLED^LAPSED^EXPIRED^COMPLETE^"
D ACTIVE^ORWPS(.ALST,ORDFN,DUZ,1,0)
S L="" K ORD F S L=$O(ALST(L)) Q:L="" I $E(ALST(L))="~" D
. I STATUS[$P(ALST(L),U,10) Q
. S MED=$P(ALST(L),U,9),MEDD=$P(ALST(L),"^",3) I $D(^OR(100,+MED,.1)) D
. . S MDA=0 F S MDA=$O(^OR(100,+MED,.1,MDA)) Q:MDA=""!(MDA'?1N.N) I $D(^OR(100,+MED,.1,MDA,0)) D
. . . S M=^OR(100,+MED,.1,MDA,0),MDARRAY(M,+MED)=MEDD_U_$$FILLID(+MED)
I $D(MDARRAY) D
. D CLRALLGY^ORWDXC("",ORDFN)
. S M="" F S M=$O(MDARRAY(M)) Q:M="" I $D(MDARRAY(M)) D
. . S MED="" F S MED=$O(MDARRAY(M,MED)) Q:MED="" D
. . . S FID=$P(MDARRAY(M,MED),U,2) I FID="" S FID="PSI"
. . . K AGYLST,AGYTXT
. . . D ALLERGY^ORWDXC(.AGYLST,ORDFN,FID,"",MED)
. . . I $$CHKMEDS2($P(GMRAGNT,U),.AGYLST,.AGYTXT) S MDARRAY2(MED,M)=$P($G(MDARRAY(M,MED)),U,1)_U_AGYTXT
. D CLRALLGY^ORWDXC("",ORDFN)
. K MDARRAY
I $D(MDARRAY2) D
. S MED="" F S MED=$O(MDARRAY2(MED)) Q:MED="" D
. . S ORD=$P($G(^OR(100,MED,0)),U,4),ENT=$P($G(^OR(100,MED,0)),U,6)
. . S M="" F S M=$O(MDARRAY2(MED,M)) Q:M="" D
. . . S LST=LST+1
. . . S LST(LST)=MED_U_M_U_$P(MDARRAY2(MED,M),U,1)
. . . I ORD]"" S $P(LST(LST),U,4)=ORD_";"_$P(^VA(200,ORD,0),U,1)
. . . I ENT]"",ORD'=ENT S $P(LST(LST),U,5)=ENT_";"_$P(^VA(200,ENT,0),U,1)
. . . S ATTEND=""
. . . S DFN=$P($G(^OR(100,+MED,0)),U,2)
. . . I $P(DFN,";",2)="DPT(" S ATTEND=$G(^DPT(DFN,.1041))
. . . I ATTEND]"",ORD'=ATTEND S $P(LST(LST),U,6)=ATTEND_";"_$P(^VA(200,ATTEND,0),U,1)
. . . S $P(LST(LST),U,7)=$P(MDARRAY2(MED,M),U,2,999)
. K MDARRAY2
K ALST,AGYLST
Q
CHKMEDS2(AGNT,AGYLST,AGYTXT) ;Scan returned allegy checks against the new allergy agent for a match
N MATCH,AGY,LOOP,AGYTXTQ,TXT,AGYSTRT,AGYSTRT1,AGYSTP
S MATCH=0,AGY=""
F S AGY=$O(AGYLST(AGY)) Q:AGY="" I AGYLST(AGY)[AGNT D
. S MATCH=1
. S AGYTXTQ=0
. S TXT=$G(AGYLST(AGY))
. S AGYSTRT=$F(TXT,"(")
. S AGYSTRT1=$F(TXT,"(",AGYSTRT)
. S AGYSTP=$F(TXT,")")
. I AGYSTRT1'=0,AGYSTRT1<AGYSTP S AGYSTP=$F(TXT,")",AGYSTP)
. ;S TXT=$P($P($G(AGYLST(AGY)),"(",2),")",1)
. S TXT=$E(TXT,AGYSTRT,AGYSTP-2)
. S LOOP="" F S LOOP=$O(AGYTXT(LOOP)) Q:LOOP="" D Q:AGYTXTQ=1
. . I TXT=""!(TXT=$G(AGYTXT(LOOP))) S AGYTXTQ=1
. I AGYTXTQ=1 Q
. S AGYTXT=$S($G(AGYTXT)'="":$G(AGYTXT)_U,1:"")_$G(TXT)
. S AGYTXT(AGY)=$G(TXT)
Q MATCH
GETPROV(LST,ORNUM,ORBDFN) ;return a list of providers related to a list of orders based on parameter option
N CNT,ORBADT,ORBATTD,ORBDUZ,ORBENT,ORBNOTIF,ORBPRIM,ORBTDEV,ORBU,ORDGPMA,ORFORCE,ORN,ORPOSIT
N ORRECIP,TEXT,TXT4,VA,VA200,VADM,VAIN,X,XQA,RECTITLE
K ^XTMP("ORBUSER",$J)
S (CNT,ORBADT)=0
S (ORDGPMA,ORFORCE)=""
S ORNUM=+$G(ORNUM) Q:ORNUM=0
S ORBDFN=+$G(ORBDFN) Q:ORBDFN=0
S ORBENT=$$ENTITY^ORB31(ORNUM)
D
. N DFN
. S DFN=ORBDFN
. S VA200=""
. D OERR^VADPT
I ('$L($G(VA("BID"))))!('$L($G(VADM(1)))) Q
S ORN=88 ;"NEW ALLERGY ENTERED/ACTIVE MED" notification
S ORBPRIM=+$P(VAIN(2),U),ORBATTD=+$P(VAIN(11),U)
D TITLE^ORB3
I $D(XQA)<10 D GETPROVQ Q
S X=0
F S X=$O(XQA(X)) Q:+X=0 D
. S ORRECIP=$P($G(^VA(200,X,0)),U,1),RECTITLE=$P($G(^(0)),U,9)
. I ORRECIP']"" Q
. S CNT=CNT+1
. S LST(CNT)=X_U_ORRECIP_U_$S(+RECTITLE:$P($G(^DIC(3.1,RECTITLE,0)),U),1:"")
S LST=CNT
GETPROVQ K ^XTMP("ORBUSER",$J)
Q
SENDALRT(Y,ORIFN,PROVLST) ;Send a group of alerts for instances where a user enters a new allergy impacting an existing med order
;ORIFN indicates the order number for which the alert will be sent
;PROVLST contains a list of additional recipients selected by the user
; Format: DUZ;VA(200^Provider Name
S Y=1
N ORBT,ORDFN,A,ORLIST
I $G(ORIFN)="" S Y=0 Q
S ORDFN=+$P($G(^OR(100,ORIFN,0)),"^",2) I ORDFN="" S Y=0 Q
S ORBT=$P($G(^ORD(100.9,88,0)),"^",3)
S A="" F S A=$O(PROVLST(A)) Q:A="" S ORLIST(+PROVLST(A))=""
D EN^ORB3(88,ORDFN,ORIFN,.ORLIST,ORBT,"NEW;"_ORIFN)
Q
FILLID(MED) ;
N DGRP,VAL,X
S VAL=""
S DGRP=$P($G(^OR(100,MED,0)),U,11)
S X=$P($P($G(^ORD(100.98,DGRP,0)),U,3)," ")
I $L(X) S VAL="PS"_$S(X="NV":"H",X="O":"O",X="UD":"I",1:"I")
Q VAL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDAL32 12081 printed Apr 09, 2024@21:34:10 Page 2
ORWDAL32 ; SLC/REV - Allergy calls to support windows ;Apr 21, 2022@08:43:40
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,190,195,233,243,539,405**;Dec 17, 1997;Build 211
+2 ;
+3 ; DBIA #4531 NAME^PSN50P41
+4 ; DBIA #4543 C^PSN50P65
+5 ; DBIA #2531 $$B^PSNAPIS, $$T^PSNAPIS
+6 ; DBIA #2574 $$TGTOG^PSNAPIS
+7 ; DBIA #4829 ALL^PSN5067
+8 ; DBIA #4683 GETREC^GMRAGUI
+9 ; DBIA #4682 EIE^GMRAGUI1, NKA^GMRAGUI1, UPDATE^GMRAGUI1
+10 ; DBIA #4374 $$SENDREQ^GMRAPES0
+11 ; DBIA #4684 SITE^GMRAUTL
+12 ; DBIA #1234 Direct global read of ^DIC(3.1
+13 ;
DEF(LST) ; Get dialog data for allergies
+1 NEW ILST,I,X
SET ILST=0
+2 SET LST($$NXT)="~Allergy Types"
DO ALLGYTYP
+3 SET LST($$NXT)="~Reactions"
DO ALLGYTYP
+4 SET LST($$NXT)="~Nature of Reaction"
DO NATREACT
+5 SET LST($$NXT)="~Top Ten"
DO TOPTEN
+6 SET LST($$NXT)="~Observ/Hist"
DO OBSHIST
+7 SET LST($$NXT)="~Severity"
DO SEVERITY
+8 QUIT
GMRASITE(ORY) ;Return GMRA Site Params
+1 NEW GMRASITE
+2 DO SITE^GMRAUTL
+3 SET ORY=$GET(^GMRD(120.84,GMRASITE,0))
+4 QUIT
TOPTEN ; Get top ten symptoms from Allergy Site Parameters file
+1 ;233
NEW X0,I,CNT,GMRASITE
SET I=0
SET X0=""
SET CNT=0
+2 ;233
DO SITE^GMRAUTL
+3 ;233
FOR
SET I=$ORDER(^GMRD(120.84,GMRASITE,1,I))
SET CNT=CNT+1
if +I=0!(CNT>10)
QUIT
Begin DoDot:1
+4 ;233 Don't send this entry
SET X0=^GMRD(120.84,GMRASITE,1,I,0)
if '$DATA(^GMRD(120.83,X0))
QUIT
if $PIECE(^GMRD(120.83,X0,0),"^")="OTHER REACTION"
QUIT
+5 ;233 Don't send if inactive term
+6 IF $LENGTH($TEXT(SCREEN^XTID))
if $$SCREEN^XTID(120.83,.01,X0_",")
QUIT
+7 SET LST($$NXT)="i"_X0_U_$P($GET(^GMRD(120.83,X0,0)),U,1)
End DoDot:1
+8 QUIT
ALLSRCH(Y,X) ; Return list of partial matches ; CHANGED TO PRODUCE TREEVIEW IN GUI
+1 NEW ORX,ROOT,XP,CNT,ORFILE,ORSRC,ORIEN,ORREAX
SET ORIEN=0
SET CNT=0
SET ORSRC=0
SET ORFILE=""
+2 SET ORX=X
SET X=$$UP^XLFSTR(X)
+3 FOR ROOT="^GMRD(120.82,""B"")","^GMRD(120.82,""D"")",$$B^PSNAPIS,$$T^PSNAPIS,"^PSDRUG(""B"")","^PSDRUG(""C"")","^PS(50.416,""P"")","^PS(50.605,""C"")"
Begin DoDot:1
+4 SET ORSRC=$GET(ORSRC)+1
SET ORFILE=$PIECE(ROOT,",",1)_")"
SET ORSRC(ORSRC)=$PIECE($TEXT(FILENAME+ORSRC),";;",2)
+5 IF (ORSRC'=2)
IF (ORSRC'=6)
SET CNT=CNT+1
SET Y(CNT)=ORSRC_U_ORSRC(ORSRC)_U_U_U_"TOP"_U_"+"
+6 IF ORSRC=1!(ORSRC=2)
Begin DoDot:2
+7 IF $DATA(@ROOT@(X))
Begin DoDot:3
+8 ;don't send this entry
IF ORSRC=1
IF X="OTHER ALLERGY/ADVERSE REACTION"
QUIT
+9 SET ORIEN=$ORDER(@ROOT@(X,0))
+10 ;233 Is term active?
IF $LENGTH($TEXT(SCREEN^XTID))
IF $$SCREEN^XTID(120.82,.01,ORIEN_",")
QUIT
+11 IF ORSRC=2
SET CNT=CNT+1
SET Y(CNT)=ORIEN_U_$PIECE($GET(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_X_">"_ROOT
+12 IF ORSRC'=2
SET CNT=CNT+1
SET Y(CNT)=ORIEN_U_X_ROOT
+13 SET Y(CNT)=Y(CNT)_U_$PIECE($GET(^GMRD(120.82,+Y(CNT),0)),U,2)_U_$SELECT(ORSRC=2:1,1:ORSRC)
End DoDot:3
+14 SET XP=X
FOR
SET XP=$ORDER(@ROOT@(XP))
if XP=""
QUIT
if $EXTRACT(XP,1,$LENGTH(X))'=X
QUIT
Begin DoDot:3
+15 ;don't send this entry
IF ORSRC=1
IF XP="OTHER ALLERGY/ADVERSE REACTION"
QUIT
+16 SET ORIEN=$ORDER(@ROOT@(XP,0))
+17 ;233 Is term active?
IF $LENGTH($TEXT(SCREEN^XTID))
IF $$SCREEN^XTID(120.82,.01,ORIEN_",")
QUIT
+18 ; partial matches
IF ORSRC=2
SET CNT=CNT+1
SET Y(CNT)=ORIEN_U_$PIECE($GET(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_XP_">"_ROOT
+19 IF ORSRC'=2
SET CNT=CNT+1
SET Y(CNT)=ORIEN_U_XP_ROOT
+20 SET Y(CNT)=Y(CNT)_U_$PIECE($GET(^GMRD(120.82,+Y(CNT),0)),U,2)_U_$SELECT(ORSRC=2:1,1:ORSRC)
End DoDot:3
End DoDot:2
+21 IF (ORSRC>2)
IF (ORSRC'=4)
IF (ORSRC'=5)
IF (ORSRC'=6)
Begin DoDot:2
+22 NEW CODE,LIST,VAL,NAME
+23 SET CODE=$SELECT(ORSRC=3:"S VAL=$$TGTOG2^PSNAPIS(X,.LIST)",ORSRC=4:"D TRDNAME(X,.LIST)",ORSRC=7:"D INGSRCH(X,.LIST)",ORSRC=8:"D CLASRCH(X,.LIST)",1:"")
if '$LENGTH(CODE)
QUIT
+24 XECUTE CODE
IF $DATA(LIST)
SET ORIEN=0
FOR
SET ORIEN=$ORDER(LIST(ORIEN))
if 'ORIEN
QUIT
Begin DoDot:3
+25 SET NAME=$PIECE(LIST(ORIEN),U,2)
+26 if $EXTRACT($PIECE(LIST(ORIEN),U,2),1,$LENGTH(X))'=X
QUIT
+27 IF $LENGTH($TEXT(SCREEN^XTID))
IF $$SCREEN^XTID($SELECT(ORSRC=3:50.6,(ORSRC=4):50.6,ORSRC=7:50.416,ORSRC=8:50.605,1:0),.01,ORIEN_",")
QUIT
+28 SET CNT=CNT+1
SET Y(CNT)=ORIEN_U_NAME_ROOT_U_"D"_U_ORSRC
End DoDot:3
End DoDot:2
+29 IF ORSRC=4
Begin DoDot:2
+30 NEW CODE,LIST,VAL,NAME
+31 SET CODE="D TRDNAME(X,.LIST)"
+32 XECUTE CODE
IF $DATA(LIST)
SET ORIEN=0
FOR
SET ORIEN=$ORDER(LIST(ORIEN))
if 'ORIEN
QUIT
Begin DoDot:3
+33 SET NAME=$PIECE(LIST(ORIEN),U,2)
+34 if $EXTRACT($PIECE(LIST(ORIEN),U,2),1,$LENGTH(X))'=X
QUIT
+35 IF $LENGTH($TEXT(SCREEN^XTID))
IF $$SCREEN^XTID(50.6,.01,+LIST(ORIEN)_",")
QUIT
+36 SET CNT=CNT+1
SET Y(CNT)=+LIST(ORIEN)_U_NAME_ROOT_U_"D"_U_ORSRC
End DoDot:3
End DoDot:2
End DoDot:1
+37 QUIT
FILENAME ; Display text of filenames for search treeview
+1 ;;VA Allergies File
+2 ;;VA Allergies File (Synonyms) SPACER ONLY - NOT DISPLAYED
+3 ;;National Drug File - Generic Drug Name
+4 ;;National Drug file - Trade Name
+5 ;;Local Drug File
+6 ;;Local Drug File (Synonyms) SPACER ONLY - NOT DISPLAYED
+7 ;;Drug Ingredients File
+8 ;;VA Drug Class File
+9 ;;
NATREACT ; Get the NATURE OF REACTION types
+1 ;Removing "R^Adverse Reaction" from choices below until we can add it as a choice in the nature of reaction/mechanism file
+2 FOR X="A^Allergy","P^Pharmacological","U^Unknown"
Begin DoDot:1
+3 SET LST($$NXT)="i"_X
End DoDot:1
+4 QUIT
ALLGYTYP ; Get the allergy types
+1 FOR X="D^Drug","F^Food","O^Other","DF^Drug,Food","DO^Drug,Other","FO^Food,Other","DFO^Drug,Food,Other"
Begin DoDot:1
+2 SET LST($$NXT)="i"_X
End DoDot:1
+3 QUIT
OBSHIST ; Observed or historical
+1 FOR X="o^Observed","h^Historical"
Begin DoDot:1
+2 SET LST($$NXT)="i"_X
End DoDot:1
+3 QUIT
SEVERITY ; Severity
+1 FOR X="3^Severe","2^Moderate","1^Mild"
Begin DoDot:1
+2 SET LST($$NXT)="i"_X
End DoDot:1
+3 QUIT
SYMPTOMS(Y,FROM,DIR) ; Return a subset of symptoms
+1 ; .Return Array, Starting Text, Direction
+2 ;233
NEW I,IEN,CNT,X,NAME,SUB,SYN
SET I=0
SET CNT=44
+3 ;233
KILL ^TMP($JOB,"SIGNS")
+4 ;The following lines were added in 233. Now accounts for synonyms
+5 ;233
MERGE ^TMP($JOB,"SIGNS","B")=^GMRD(120.83,"B")
+6 ;233
SET SYN=""
FOR
SET SYN=$ORDER(^GMRD(120.83,"D",SYN))
if SYN=""
QUIT
SET SUB=0
FOR
SET SUB=$ORDER(^GMRD(120.83,"D",SYN,SUB))
if '+SUB
QUIT
Begin DoDot:1
+7 ;233
SET NAME=$PIECE(^GMRD(120.83,SUB,0),U)
SET ^TMP($JOB,"SIGNS","B",(SYN_$CHAR(9)_"<"_NAME_">"_U_NAME),SUB)=""
End DoDot:1
+8 ;233
FOR
if I'<CNT
QUIT
SET FROM=$ORDER(^TMP($JOB,"SIGNS","B",FROM),DIR)
if FROM=""
QUIT
Begin DoDot:1
+9 ;Don't send this entry
IF FROM="OTHER REACTION"
QUIT
+10 ;233
SET IEN=0
FOR
SET IEN=$ORDER(^TMP($JOB,"SIGNS","B",FROM,IEN))
if 'IEN
QUIT
Begin DoDot:2
+11 ;233 Is term active
IF $LENGTH($TEXT(SCREEN^XTID))
IF $$SCREEN^XTID(120.83,.01,IEN_",")
QUIT
+12 SET I=I+1
+13 SET Y(I)=IEN_U_FROM
End DoDot:2
End DoDot:1
+14 QUIT
NXT() ; Increment index of LST
+1 SET ILST=ILST+1
+2 QUIT ILST
EDITLOAD(Y,ORALIEN) ; Load an allergy/adverse reaction for editing
+1 if +$GET(ORALIEN)=0
QUIT
+2 NEW ORNODE,I
+3 SET ORNODE=$NAME(^TMP("GMRA",$JOB))
SET I=0
+4 ;following patch check is made via GUI RPC call to ORWU PATCH instead
+5 ;I '$$PATCH^XPDUTL("GMRA*4.0*21") S @ORNODE@(0)="-1^Not yet implemented",Y=ORNODE Q
+6 DO GETREC^GMRAGUI(ORALIEN,ORNODE)
+7 SET Y=ORNODE
+8 QUIT
EDITSAVE(ORY,ORALIEN,ORDFN,OREDITED) ; Save Edit/Add of an allergy/adverse reaction
+1 ;following patch check is made via GUI RPC call to ORWU PATCH instead
+2 ;I '$$PATCH^XPDUTL("GMRA*4.0*21") S Y="-1^Not yet implemented" Q
+3 NEW ORNODE
+4 SET ORNODE=$NAME(^TMP("GMRA",$JOB))
+5 KILL @ORNODE
MERGE @ORNODE=OREDITED
+6 SET ORY=0
+7 ;Handle entered in error
IF $GET(@ORNODE@("GMRAERR"))="YES"
DO EIE^GMRAGUI1(ORALIEN,ORDFN,ORNODE)
QUIT
+8 IF $GET(@ORNODE@("GMRANKA"))="YES"
DO NKA^GMRAGUI1
QUIT
+9 ;Add/edit reactions
DO UPDATE^GMRAGUI1(ORALIEN,ORDFN,ORNODE)
QUIT
+10 QUIT
SENDBULL(Y,ORDUZ,ORDFN,ORTEXT,ORCMTS) ; Send bulletin if user attempts free-text entry
+1 IF '$DATA(ORCMTS)
Begin DoDot:1
+2 SET Y=$$SENDREQ^GMRAPES0(ORDUZ,ORDFN,ORTEXT)
End DoDot:1
+3 IF '$TEST
Begin DoDot:1
+4 SET Y=$$SENDREQ^GMRAPES0(ORDUZ,ORDFN,ORTEXT,.ORCMTS)
End DoDot:1
+5 QUIT
INGSRCH(NAME,LIST) ;
+1 KILL ^TMP($JOB,"ORWDAL32")
+2 DO NAME^PSN50P41(NAME,"ORWDAL32")
+3 IF $DATA(^TMP($JOB,"ORWDAL32","P"))
Begin DoDot:1
+4 NEW I
SET I=""
FOR
SET I=$ORDER(^TMP($JOB,"ORWDAL32","P",I))
if I=""
QUIT
Begin DoDot:2
+5 NEW J
SET J=0
FOR
SET J=$ORDER(^TMP($JOB,"ORWDAL32","P",I,J))
if 'J
QUIT
SET LIST(J)=J_U_I
End DoDot:2
End DoDot:1
+6 KILL ^TMP($JOB,"ORWDAL32")
+7 QUIT
CLASRCH(NAME,LIST) ;
+1 KILL ^TMP($JOB,"ORWDAL32")
+2 DO C^PSN50P65(,NAME,"ORWDAL32")
+3 IF $DATA(^TMP($JOB,"ORWDAL32","C"))
Begin DoDot:1
+4 NEW I
SET I=""
FOR
SET I=$ORDER(^TMP($JOB,"ORWDAL32","C",I))
if I=""
QUIT
Begin DoDot:2
+5 NEW J
SET J=0
FOR
SET J=$ORDER(^TMP($JOB,"ORWDAL32","C",I,J))
if 'J
QUIT
SET LIST(J)=J_U_$GET(^TMP($JOB,"ORWDAL32",J,1))
End DoDot:2
End DoDot:1
+6 KILL ^TMP($JOB,"ORWDAL32")
+7 QUIT
TRDNAME(NAME,LIST) ;
+1 KILL ^TMP($JOB,"ORWDAL32")
+2 DO ALL^PSN5067(,NAME,,"ORWDAL32")
+3 IF $DATA(^TMP($JOB,"ORWDAL32","B"))
Begin DoDot:1
+4 NEW I
SET I=""
FOR
SET I=$ORDER(^TMP($JOB,"ORWDAL32","B",I))
if I=""
QUIT
Begin DoDot:2
+5 NEW J,K
SET J=$ORDER(^TMP($JOB,"ORWDAL32","B",I,0))
if 'J
QUIT
SET K=$$TGTOG^PSNAPIS(I)
SET LIST(J)=K_U_$GET(^TMP($JOB,"ORWDAL32",J,4))
End DoDot:2
End DoDot:1
+6 KILL ^TMP($JOB,"ORWDAL32")
+7 QUIT
CHKMEDS(LST,ORDFN,GMRAGNT) ;Check a newly entered allergy against existing orders
+1 NEW ALST,L,MED,M,AGYLST,ORD,ENT,DFN,ATTEND,MDA,MEDD,MDARRAY,MDARRAY2,FILLID,STATUS,FID,AGYTXT
+2 SET LST=0
+3 SET STATUS="^DISCONTINUED^DISCONTINUED (EDIT)^CANCELLED^LAPSED^EXPIRED^COMPLETE^"
+4 DO ACTIVE^ORWPS(.ALST,ORDFN,DUZ,1,0)
+5 SET L=""
KILL ORD
FOR
SET L=$ORDER(ALST(L))
if L=""
QUIT
IF $EXTRACT(ALST(L))="~"
Begin DoDot:1
+6 IF STATUS[$PIECE(ALST(L),U,10)
QUIT
+7 SET MED=$PIECE(ALST(L),U,9)
SET MEDD=$PIECE(ALST(L),"^",3)
IF $DATA(^OR(100,+MED,.1))
Begin DoDot:2
+8 SET MDA=0
FOR
SET MDA=$ORDER(^OR(100,+MED,.1,MDA))
if MDA=""!(MDA'?1N.N)
QUIT
IF $DATA(^OR(100,+MED,.1,MDA,0))
Begin DoDot:3
+9 SET M=^OR(100,+MED,.1,MDA,0)
SET MDARRAY(M,+MED)=MEDD_U_$$FILLID(+MED)
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF $DATA(MDARRAY)
Begin DoDot:1
+11 DO CLRALLGY^ORWDXC("",ORDFN)
+12 SET M=""
FOR
SET M=$ORDER(MDARRAY(M))
if M=""
QUIT
IF $DATA(MDARRAY(M))
Begin DoDot:2
+13 SET MED=""
FOR
SET MED=$ORDER(MDARRAY(M,MED))
if MED=""
QUIT
Begin DoDot:3
+14 SET FID=$PIECE(MDARRAY(M,MED),U,2)
IF FID=""
SET FID="PSI"
+15 KILL AGYLST,AGYTXT
+16 DO ALLERGY^ORWDXC(.AGYLST,ORDFN,FID,"",MED)
+17 IF $$CHKMEDS2($PIECE(GMRAGNT,U),.AGYLST,.AGYTXT)
SET MDARRAY2(MED,M)=$PIECE($GET(MDARRAY(M,MED)),U,1)_U_AGYTXT
End DoDot:3
End DoDot:2
+18 DO CLRALLGY^ORWDXC("",ORDFN)
+19 KILL MDARRAY
End DoDot:1
+20 IF $DATA(MDARRAY2)
Begin DoDot:1
+21 SET MED=""
FOR
SET MED=$ORDER(MDARRAY2(MED))
if MED=""
QUIT
Begin DoDot:2
+22 SET ORD=$PIECE($GET(^OR(100,MED,0)),U,4)
SET ENT=$PIECE($GET(^OR(100,MED,0)),U,6)
+23 SET M=""
FOR
SET M=$ORDER(MDARRAY2(MED,M))
if M=""
QUIT
Begin DoDot:3
+24 SET LST=LST+1
+25 SET LST(LST)=MED_U_M_U_$PIECE(MDARRAY2(MED,M),U,1)
+26 IF ORD]""
SET $PIECE(LST(LST),U,4)=ORD_";"_$PIECE(^VA(200,ORD,0),U,1)
+27 IF ENT]""
IF ORD'=ENT
SET $PIECE(LST(LST),U,5)=ENT_";"_$PIECE(^VA(200,ENT,0),U,1)
+28 SET ATTEND=""
+29 SET DFN=$PIECE($GET(^OR(100,+MED,0)),U,2)
+30 IF $PIECE(DFN,";",2)="DPT("
SET ATTEND=$GET(^DPT(DFN,.1041))
+31 IF ATTEND]""
IF ORD'=ATTEND
SET $PIECE(LST(LST),U,6)=ATTEND_";"_$PIECE(^VA(200,ATTEND,0),U,1)
+32 SET $PIECE(LST(LST),U,7)=$PIECE(MDARRAY2(MED,M),U,2,999)
End DoDot:3
End DoDot:2
+33 KILL MDARRAY2
End DoDot:1
+34 KILL ALST,AGYLST
+35 QUIT
CHKMEDS2(AGNT,AGYLST,AGYTXT) ;Scan returned allegy checks against the new allergy agent for a match
+1 NEW MATCH,AGY,LOOP,AGYTXTQ,TXT,AGYSTRT,AGYSTRT1,AGYSTP
+2 SET MATCH=0
SET AGY=""
+3 FOR
SET AGY=$ORDER(AGYLST(AGY))
if AGY=""
QUIT
IF AGYLST(AGY)[AGNT
Begin DoDot:1
+4 SET MATCH=1
+5 SET AGYTXTQ=0
+6 SET TXT=$GET(AGYLST(AGY))
+7 SET AGYSTRT=$FIND(TXT,"(")
+8 SET AGYSTRT1=$FIND(TXT,"(",AGYSTRT)
+9 SET AGYSTP=$FIND(TXT,")")
+10 IF AGYSTRT1'=0
IF AGYSTRT1<AGYSTP
SET AGYSTP=$FIND(TXT,")",AGYSTP)
+11 ;S TXT=$P($P($G(AGYLST(AGY)),"(",2),")",1)
+12 SET TXT=$EXTRACT(TXT,AGYSTRT,AGYSTP-2)
+13 SET LOOP=""
FOR
SET LOOP=$ORDER(AGYTXT(LOOP))
if LOOP=""
QUIT
Begin DoDot:2
+14 IF TXT=""!(TXT=$GET(AGYTXT(LOOP)))
SET AGYTXTQ=1
End DoDot:2
if AGYTXTQ=1
QUIT
+15 IF AGYTXTQ=1
QUIT
+16 SET AGYTXT=$SELECT($GET(AGYTXT)'="":$GET(AGYTXT)_U,1:"")_$GET(TXT)
+17 SET AGYTXT(AGY)=$GET(TXT)
End DoDot:1
+18 QUIT MATCH
GETPROV(LST,ORNUM,ORBDFN) ;return a list of providers related to a list of orders based on parameter option
+1 NEW CNT,ORBADT,ORBATTD,ORBDUZ,ORBENT,ORBNOTIF,ORBPRIM,ORBTDEV,ORBU,ORDGPMA,ORFORCE,ORN,ORPOSIT
+2 NEW ORRECIP,TEXT,TXT4,VA,VA200,VADM,VAIN,X,XQA,RECTITLE
+3 KILL ^XTMP("ORBUSER",$JOB)
+4 SET (CNT,ORBADT)=0
+5 SET (ORDGPMA,ORFORCE)=""
+6 SET ORNUM=+$GET(ORNUM)
if ORNUM=0
QUIT
+7 SET ORBDFN=+$GET(ORBDFN)
if ORBDFN=0
QUIT
+8 SET ORBENT=$$ENTITY^ORB31(ORNUM)
+9 Begin DoDot:1
+10 NEW DFN
+11 SET DFN=ORBDFN
+12 SET VA200=""
+13 DO OERR^VADPT
End DoDot:1
+14 IF ('$LENGTH($GET(VA("BID"))))!('$LENGTH($GET(VADM(1))))
QUIT
+15 ;"NEW ALLERGY ENTERED/ACTIVE MED" notification
SET ORN=88
+16 SET ORBPRIM=+$PIECE(VAIN(2),U)
SET ORBATTD=+$PIECE(VAIN(11),U)
+17 DO TITLE^ORB3
+18 IF $DATA(XQA)<10
DO GETPROVQ
QUIT
+19 SET X=0
+20 FOR
SET X=$ORDER(XQA(X))
if +X=0
QUIT
Begin DoDot:1
+21 SET ORRECIP=$PIECE($GET(^VA(200,X,0)),U,1)
SET RECTITLE=$PIECE($GET(^(0)),U,9)
+22 IF ORRECIP']""
QUIT
+23 SET CNT=CNT+1
+24 SET LST(CNT)=X_U_ORRECIP_U_$SELECT(+RECTITLE:$PIECE($GET(^DIC(3.1,RECTITLE,0)),U),1:"")
End DoDot:1
+25 SET LST=CNT
GETPROVQ KILL ^XTMP("ORBUSER",$JOB)
+1 QUIT
SENDALRT(Y,ORIFN,PROVLST) ;Send a group of alerts for instances where a user enters a new allergy impacting an existing med order
+1 ;ORIFN indicates the order number for which the alert will be sent
+2 ;PROVLST contains a list of additional recipients selected by the user
+3 ; Format: DUZ;VA(200^Provider Name
+4 SET Y=1
+5 NEW ORBT,ORDFN,A,ORLIST
+6 IF $GET(ORIFN)=""
SET Y=0
QUIT
+7 SET ORDFN=+$PIECE($GET(^OR(100,ORIFN,0)),"^",2)
IF ORDFN=""
SET Y=0
QUIT
+8 SET ORBT=$PIECE($GET(^ORD(100.9,88,0)),"^",3)
+9 SET A=""
FOR
SET A=$ORDER(PROVLST(A))
if A=""
QUIT
SET ORLIST(+PROVLST(A))=""
+10 DO EN^ORB3(88,ORDFN,ORIFN,.ORLIST,ORBT,"NEW;"_ORIFN)
+11 QUIT
FILLID(MED) ;
+1 NEW DGRP,VAL,X
+2 SET VAL=""
+3 SET DGRP=$PIECE($GET(^OR(100,MED,0)),U,11)
+4 SET X=$PIECE($PIECE($GET(^ORD(100.98,DGRP,0)),U,3)," ")
+5 IF $LENGTH(X)
SET VAL="PS"_$SELECT(X="NV":"H",X="O":"O",X="UD":"I",1:"I")
+6 QUIT VAL
