ORWDAL32 ; SLC/REV - Allergy calls to support windows ;10-May-2012 12:54;DU
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,190,1007,1008,195,233,243,1010**;Dec 17, 1997;Build 47
; Modified - 08/17/11 - IHS/MSC/MGH - ALLSRCH
; - 04/02/12 - IHS/MSC/MGH - Added logic to support Sign/Symptom status and "B" xref lookup for allergy status
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,INAC,INACT,ORIEN,ORREAX S ORIEN=0,CNT=0,ORSRC=0,ORFILE="",ORREAX=""
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 INACT=0,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
... ;IHS/MSC/MGH 1008
... I ORSRC=5!(ORSRC=6) Q ;Patch 8 don't send file 50 entries
... ;IHS/MSC/MGH Screen out inactive allergies
... S ORIEN=$O(@ROOT@(X,0))
... I ORSRC=1!(ORSRC=2) S INAC=$$CHECK(ORIEN) Q:+INAC
... ;end of mods
... 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 ORSRC=1,XP="OTHER ALLERGY/ADVERSE REACTION" Q ;IHS/MSC/MGH 1008
... ;IHS/MSC/MGH Changes made to screen out inactive allergies
... I ORSRC=5!(ORSRC=6) Q
... I ORSRC=1!(ORSRC=2) S INAC=$$CHECK(ORIEN) Q:+INAC
... ;End of mods
... 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,INACS,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
. . S INACS=$$CHECKS(IEN) Q:+INACS ;IHS/MSC/MGH 1010
. . 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
CHECK(ORIEN) ;Check to see if allergy is active)
N VALUE,STAT,STATUS,TERMDT
S VALUE=0
S TERMDT=$O(^GMRD(120.82,ORIEN,"TERMSTATUS","B",$C(0)),-1) I TERMDT'="" D
.S STAT=$O(^GMRD(120.82,ORIEN,"TERMSTATUS","B",TERMDT,$C(0)),-1) I STAT'="" D
..S STATUS=$P($G(^GMRD(120.82,ORIEN,"TERMSTATUS",STAT,0)),U,2)
..I STATUS=0 S VALUE=1
Q VALUE
CHECKS(SGN) ;Check to see if SIGN/SYMPTOM is active)
N VALUE,STAT,STATUS,SIGNDT
S VALUE=0,SIGNDT=""
S SIGNDT=$O(^GMRD(120.83,SGN,"TERMSTATUS","B",$C(0)),-1) I SIGNDT'="" D
.S STAT=$O(^GMRD(120.83,SGN,"TERMSTATUS","B",SIGNDT,$C(0)),-1) I STAT'="" D
..S STATUS=$P($G(^GMRD(120.83,SGN,"TERMSTATUS",STAT,0)),U,2)
..I STATUS=0 S VALUE=1
Q VALUE
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
ORWDAL32 ; SLC/REV - Allergy calls to support windows ;10-May-2012 12:54;DU
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,190,1007,1008,195,233,243,1010**;Dec 17, 1997;Build 47
+2 ; Modified - 08/17/11 - IHS/MSC/MGH - ALLSRCH
+3 ; - 04/02/12 - IHS/MSC/MGH - Added logic to support Sign/Symptom status and "B" xref lookup for allergy status
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,INAC,INACT,ORIEN,ORREAX
SET ORIEN=0
SET CNT=0
SET ORSRC=0
SET ORFILE=""
SET ORREAX=""
+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 INACT=0
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 ;IHS/MSC/MGH 1008
+10 ;Patch 8 don't send file 50 entries
IF ORSRC=5!(ORSRC=6)
QUIT
+11 ;IHS/MSC/MGH Screen out inactive allergies
+12 SET ORIEN=$ORDER(@ROOT@(X,0))
+13 IF ORSRC=1!(ORSRC=2)
SET INAC=$$CHECK(ORIEN)
IF +INAC
QUIT
+14 ;end of mods
+15 ;233 Is term active?
IF $LENGTH($TEXT(SCREEN^XTID))
IF $$SCREEN^XTID(120.82,.01,ORIEN_",")
QUIT
+16 IF ORSRC=2
SET CNT=CNT+1
SET Y(CNT)=ORIEN_U_$PIECE($GET(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_X_">"_ROOT
+17 IF ORSRC'=2
SET CNT=CNT+1
SET Y(CNT)=ORIEN_U_X_ROOT
+18 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
+19 SET XP=X
FOR
SET XP=$ORDER(@ROOT@(XP))
IF XP=""
QUIT
IF $EXTRACT(XP,1,$LENGTH(X))'=X
QUIT
Begin DoDot:3
+20 ;don't send this entry
IF ORSRC=1
IF XP="OTHER ALLERGY/ADVERSE REACTION"
QUIT
+21 SET ORIEN=$ORDER(@ROOT@(XP,0))
+22 ;IHS/MSC/MGH 1008
IF ORSRC=1
IF XP="OTHER ALLERGY/ADVERSE REACTION"
QUIT
+23 ;IHS/MSC/MGH Changes made to screen out inactive allergies
+24 IF ORSRC=5!(ORSRC=6)
QUIT
+25 IF ORSRC=1!(ORSRC=2)
SET INAC=$$CHECK(ORIEN)
IF +INAC
QUIT
+26 ;End of mods
+27 ;233 Is term active?
IF $LENGTH($TEXT(SCREEN^XTID))
IF $$SCREEN^XTID(120.82,.01,ORIEN_",")
QUIT
+28 ; 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
+29 IF ORSRC'=2
SET CNT=CNT+1
SET Y(CNT)=ORIEN_U_XP_ROOT
+30 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
+31 IF (ORSRC>2)
IF (ORSRC'=4)
IF (ORSRC'=5)
IF (ORSRC'=6)
Begin DoDot:2
+32 NEW CODE,LIST,VAL,NAME
+33 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
+34 XECUTE CODE
IF $DATA(LIST)
SET ORIEN=0
FOR
SET ORIEN=$ORDER(LIST(ORIEN))
IF 'ORIEN
QUIT
Begin DoDot:3
+35 SET NAME=$PIECE(LIST(ORIEN),U,2)
+36 IF $EXTRACT($PIECE(LIST(ORIEN),U,2),1,$LENGTH(X))'=X
QUIT
+37 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
+38 SET CNT=CNT+1
SET Y(CNT)=ORIEN_U_NAME_ROOT_U_"D"_U_ORSRC
End DoDot:3
End DoDot:2
+39 IF ORSRC=4
Begin DoDot:2
+40 NEW CODE,LIST,VAL,NAME
+41 SET CODE="D TRDNAME(X,.LIST)"
+42 XECUTE CODE
IF $DATA(LIST)
SET ORIEN=0
FOR
SET ORIEN=$ORDER(LIST(ORIEN))
IF 'ORIEN
QUIT
Begin DoDot:3
+43 SET NAME=$PIECE(LIST(ORIEN),U,2)
+44 IF $EXTRACT($PIECE(LIST(ORIEN),U,2),1,$LENGTH(X))'=X
QUIT
+45 IF $LENGTH($TEXT(SCREEN^XTID))
IF $$SCREEN^XTID(50.6,.01,+LIST(ORIEN)_",")
QUIT
+46 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
+47 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 NEW I,IEN,CNT,X,NAME,SUB,INACS,SYN
+3 ;233
SET I=0
SET CNT=44
+4 ;233
KILL ^TMP($JOB,"SIGNS")
+5 ;The following lines were added in 233. Now accounts for synonyms
+6 ;233
MERGE ^TMP($JOB,"SIGNS","B")=^GMRD(120.83,"B")
+7 ;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
+8 ;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
+9 ;233
FOR
IF I'<CNT
QUIT
SET FROM=$ORDER(^TMP($JOB,"SIGNS","B",FROM),DIR)
IF FROM=""
QUIT
Begin DoDot:1
+10 ;Don't send this entry
IF FROM="OTHER REACTION"
QUIT
+11 ;233
SET IEN=0
FOR
SET IEN=$ORDER(^TMP($JOB,"SIGNS","B",FROM,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+12 ;IHS/MSC/MGH 1010
SET INACS=$$CHECKS(IEN)
IF +INACS
QUIT
+13 ;233 Is term active
IF $LENGTH($TEXT(SCREEN^XTID))
IF $$SCREEN^XTID(120.83,.01,IEN_",")
QUIT
+14 SET I=I+1
+15 SET Y(I)=IEN_U_FROM
End DoDot:2
End DoDot:1
+16 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
CHECK(ORIEN) ;Check to see if allergy is active)
+1 NEW VALUE,STAT,STATUS,TERMDT
+2 SET VALUE=0
+3 SET TERMDT=$ORDER(^GMRD(120.82,ORIEN,"TERMSTATUS","B",$CHAR(0)),-1)
IF TERMDT'=""
Begin DoDot:1
+4 SET STAT=$ORDER(^GMRD(120.82,ORIEN,"TERMSTATUS","B",TERMDT,$CHAR(0)),-1)
IF STAT'=""
Begin DoDot:2
+5 SET STATUS=$PIECE($GET(^GMRD(120.82,ORIEN,"TERMSTATUS",STAT,0)),U,2)
+6 IF STATUS=0
SET VALUE=1
End DoDot:2
End DoDot:1
+7 QUIT VALUE
CHECKS(SGN) ;Check to see if SIGN/SYMPTOM is active)
+1 NEW VALUE,STAT,STATUS,SIGNDT
+2 SET VALUE=0
SET SIGNDT=""
+3 SET SIGNDT=$ORDER(^GMRD(120.83,SGN,"TERMSTATUS","B",$CHAR(0)),-1)
IF SIGNDT'=""
Begin DoDot:1
+4 SET STAT=$ORDER(^GMRD(120.83,SGN,"TERMSTATUS","B",SIGNDT,$CHAR(0)),-1)
IF STAT'=""
Begin DoDot:2
+5 SET STATUS=$PIECE($GET(^GMRD(120.83,SGN,"TERMSTATUS",STAT,0)),U,2)
+6 IF STATUS=0
SET VALUE=1
End DoDot:2
End DoDot:1
+7 QUIT VALUE
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
