GMRAPES0 ;HIRMFO/RM-SELECT PATIENT ALLERGY TO EDIT ;11/16/07 10:26
;;4.0;Adverse Reaction Tracking;**13,17,19,21,23,20,41**;Mar 29, 1996;Build 8
;DBIA Section
;PSN5067 - 4829
;DIC - 10006
;DICN - 10009
;DIQ - 2056
;DIR - 10026
;DIWE - 10028
;PSNAPIS - 2574
;PSNDI - 4554
;XLFDT - 10103
;XLFSTR - 10104
;XMD - 10070
;XTID - 4631
EN1 ; GIVEN DFN, SELECT PATIENT ALLERGY
N GMRAGOUT,ROOT,CNT,LST,NAM,DIR,GMRAET
S GMRARET=0
S GMRAPA=-1,GMRANEW=0 R !!,"Enter Causative Agent: ",GMRALAR:DTIME S:'$T GMRALAR="^^" S:GMRALAR="" GMRARET=1 I "^^"[GMRALAR S GMRAOUT='$L(GMRALAR)+1 G Q1
I GMRALAR?1P.E!($L(GMRALAR)<3)!($L(GMRALAR)>30) S GMRAHLP=1 D EN1^GMRAHLP0 G EN1:'GMRAOUT,Q1
I GMRALAR?.E1L.E S GMRALAR=$$UP^XLFSTR(GMRALAR)
PAL K Y,DTOUT,DUOUT S DGSENFLG="",DIC="^GMR(120.8,",DIC(0)="SEZ",X=GMRANAM,DIC("S")="I '+$G(^(""ER"")),$P(^(0),U,2)?@(""1""""""_GMRALAR_"""""".E""),$D(^GMR(120.8,""B"",DFN,+Y))",DIC("W")="W $P(^(0),U,2)"
W !!,"Checking existing PATIENT ALLERGIES (#120.8) file for matches...",!
D ^DIC S X=$P($G(Y(0)),"^",2) K DIC,DGSENFLG,DTOUT,DUOUT D DIC I GMRAOUT S GMRAOUT=GMRAOUT-1 G:GMRAOUT Q1 G EN1
S:+Y>0 GMRAPA=+Y G Q1:+Y>0!GMRAOUT,PAL:X?1"?".E,EN1:Y=0
G Q1:'GMRALAGO
NPA W !!,"Now checking GMR ALLERGIES (#120.82) file for matches...",!
S DIC("S")="I $P(^(0),U)'=""OTHER ALLERGY/ADVERSE REACTION""&($S($L($T(SCREEN^XTID)):'$$SCREEN^XTID(120.82,.01,Y_"",""),1:1))" ;21,23
K Y,DTOUT,DUOUT S X=GMRALAR,DIC="^GMRD(120.82,",DIC(0)="EZM",DIC("W")="" D ^DIC K DIC S:+Y>0 X=$P(Y,"^",2) D DIC I GMRAOUT S GMRAOUT=GMRAOUT-1 G:GMRAOUT Q1 G EN1
I +Y>0 S GMRAAR=+Y_";GMRD(120.82,",GMRAAR(0)=$P(Y,"^",2),GMRAAR("O")=$P(Y(0),"^",2) D:'GMRAOUT ADAR^GMRAPES1 G EN1:GMRAPA'>0,Q1
G Q1:GMRAOUT,NPA:X?1"?".E,EN1:Y=0
NDF ;find partial matches and select from NDF
K Y,DTOUT,DUOUT
W !!,"Now checking the National Drug File - Generic Names (#50.6)",!
S DIC=50.6,X=GMRALAR,DIC(0)="EZM",DIC("S")="I $S($L($T(SCREEN^XTID)):'$$SCREEN^XTID(50.6,.01,Y_"",""),1:1)" D DIC^PSNDI(50.6,"GMRA",.DIC,.X,,$$DT^XLFDT) K DIC D DIC ;23,41
I +Y>0 S GMRAAR=+Y_";PSNDF(50.6,",GMRAAR(0)=$P(Y,U,2),GMRAAR("O")="D" D:'GMRAOUT ADAR^GMRAPES1 G EN1:GMRAPA'>0,Q1
W !!,"Now checking the National Drug File - Trade Names (#50.67)",!
K DUOUT,DTOUT,Y
S ROOT="^TMP($J,""GMRASEL"",""B"")",CNT=0,X=GMRALAR ;41
D ALL^PSN5067(,X,$$DT^XLFDT,"GMRASEL") ;41
I $D(@ROOT@(X)),$S($L($T(SCREEN^XTID)):'$$SCREEN^XTID(50.6,.01,$$TGTOG^PSNAPIS(X)_","),1:1) S CNT=CNT+1,LST(CNT)=$$TGTOG^PSNAPIS(X)_U_X ;23 Exact match stores IEN in 50.6 along with trade name
S NAM=X F S NAM=$O(@ROOT@(NAM)) Q:NAM=""!($E(NAM,1,$L(X))'=X) D
.Q:$S($L($T(SCREEN^XTID)):$$SCREEN^XTID(50.6,.01,$$TGTOG^PSNAPIS(NAM)_","),1:0) ;23
.S CNT=CNT+1,LST(CNT)=$$TGTOG^PSNAPIS(NAM)_U_NAM
I 'CNT S Y=-1 ;No matches found
I CNT=1 S Y(0)=LST(1),X=$P(Y(0),U,2),Y=+LST(1) ;Only one choice
I CNT>1 D
.D MATCHES
.S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": "
.S DIR("?")="Select the number of desired causative agent"
.D ^DIR S Y=$S(+Y:+Y,1:-1) S:Y>0 Y(0)=LST(Y),X=$P(Y(0),U,2)
D DIC I GMRAOUT S GMRAOUT=GMRAOUT=1 G:GMRAOUT Q1 G EN1
I +Y>0 S GMRAAR=+Y(0)_";PSNDF(50.6,",GMRAAR(0)=$P(Y(0),U,2),GMRAAR("O")="D" D:'GMRAOUT ADAR^GMRAPES1 G EN1:GMRAPA'>0,Q1
;Selection from file 50 removed in patch 23 and code actually removed in 41
;19 - Moved ING and CLASS code here
ING W !!,"Now checking the INGREDIENTS (#50.416) file for matches...",!
K Y,DTOUT,DUOUT S D="P",DIC="^PS(50.416,",DIC(0)="SEMZ",DIC("S")="I $S($L($T(SCREEN^XTID)):'$$SCREEN^XTID(50.416,.01,Y_"",""),1:1)",X=GMRALAR D IX^PSNDI(50.416,"GMRA",.DIC,D,.X,,$$DT^XLFDT) K DIC D DIC ;41
I GMRAOUT S GMRAOUT=GMRAOUT-1 G:GMRAOUT Q1 G EN1 ;41
I +Y>0 S GMRAAR=+Y_";PS(50.416,",GMRAAR(0)=$S(X?1A.E:X,1:$P(Y,"^",2)),GMRAAR("O")="D" D:'GMRAOUT ADAR^GMRAPES1 G EN1:GMRAPA'>0,Q1
G Q1:GMRAOUT,ING:X?1"?".E,EN1:Y=0
CLASS W !!,"Now checking VA DRUG CLASS (50.605) file for matches...",!
K Y,DTOUT,DUOUT S X=GMRALAR,DIC="^PS(50.605,",DIC(0)="SEZ",D="C",DIC("S")="I $S($L($T(SCREEN^XTID)):'$$SCREEN^XTID(50.605,.01,Y_"",""),1:1)" D IX^PSNDI(50.605,"GMRA",.DIC,D,.X,,$$DT^XLFDT) K DIC D DIC ;41
I GMRAOUT S GMRAOUT=GMRAOUT-1 G:GMRAOUT Q1 G EN1 ;41
I +Y>0 S GMRAAR=+Y_";PS(50.605,",GMRAAR(0)=$S(X?1A.E:X,1:$P(Y,"^",2)),GMRAAR("O")="D" D:'GMRAOUT ADAR^GMRAPES1 G EN1:GMRAPA'>0,Q1
G Q1:GMRAOUT,CLASS:X?1"?".E,EN1:Y=0
YNOTH W !!,"Could not find ",GMRALAR," in any files."
W !!,"Before sending an email requesting the addition of a new reactant, please",!,"try entering the first 3 or 4 letters of the reactant to search for",!,"the desired entry.",!
W !,"Would you like to send an email requesting ",GMRALAR,!,"be added as a causative agent?"
S DIR("A")="Send email"
S DIR(0)="Y",DIR("B")="NO",DIR("?")="^D MESS^GMRAPES0"
D ^DIR
I Y'=+Y S GMRAOUT=1 G Q1
I '+Y G EN1
YNDRG ;
D GETINPUT(.GMRAET)
S X=$$SENDREQ(DUZ,DFN,GMRALAR,.GMRAET)
I '+X W !!,"Error - Message not sent - ",$P(X,U,2)
I +X W !!,"Message sent - NOTE: This reactant was NOT added for this patient."
W !
Q1 ;
S:GMRAPA>0 GMRAPA(0)=$S($D(^GMR(120.8,+GMRAPA,0)):^(0),1:"")
K %,D,DA,DIC,DTOUT,DUOUT,GMRAAR,GMRAHLP,GMRAING,GMRALAGO,GMRALAR,PSNDA,PSODA,X,Y
Q
DIC ; VALIDATE LOOKUP FOR A/AR
S:$D(DTOUT) X="^^" I X="^^" S GMRAOUT=1 Q
S:$D(DUOUT) Y=0 Q:+Y'>0
YNOK W !?3,X," OK" S %=1 D YN^DICN S:%=-1 GMRAOUT=1,Y=-1 Q:GMRAOUT S:%=2 Y=-1 Q:Y=-1 S:$$DUPCHK(X,DFN,Y) Y=-1 Q:GMRAOUT I % W ! Q ;19
W !?5,$C(7),"ANSWER YES IF THIS IS THE CORRECT ALLERGY/ADVERSE REACTION,",!?5,"ELSE ANSWER NO."
G YNOK
DUPCHK(X,Y,Z) ;CHECK FOR ENTERED IN ERROR
N GMRAPA,GMRAGOUT,%,%Y S GMRAGOUT=0
I $P($G(^GMR(120.8,+Z,0)),U,2)=X Q GMRAGOUT
I $O(^GMR(120.8,"B",Y,0)) S GMRAPA=0 F S GMRAPA=$O(^GMR(120.8,"B",Y,GMRAPA)) Q:GMRAPA<1 D Q:GMRAOUT!(GMRAGOUT)
.I $P(^GMR(120.8,GMRAPA,0),U,2)'=X Q
.I $D(^GMR(120.8,GMRAPA,"ER")) D
..F S %=2 W !,?5,$C(7),"This Agent has been Entered in Error once before.",!,?5,"Are you sure you want to select this Agent again" D Q:%
...D YN^DICN S:%'=1 %=2,GMRAOUT=1 S:%Y?2"^" GMRAOUT=2
...Q:% W !,?10,"ENTER 'Y' FOR YES OR 'N' FOR NO"
...Q
..S GMRAGOUT=%
..Q
.Q
I GMRAGOUT=0 S GMRAGOUT=1
Q (GMRAGOUT-1)
MATCHES ; -- List matches for NDF
N I,J,QUIT
W !!,"Choose from the following "_+$G(CNT)_" matches:"
S (I,J,QUIT)=0 F S I=$O(LST(I)) Q:I'>0 D Q:QUIT
. S J=J+1 I '(J#(IOSL-5)) S:'$$MORE QUIT=1 Q:QUIT
. W !,J," ",$P(LST(I),"^",2)
Q
;
MORE() ; -- show more matches
N DIR,DTOUT,DUOUT,X,Y
S DIR(0)="EA",DIR("A")="Press <return> to see more, or ^ to stop ..."
D ^DIR
Q +Y
;
SENDREQ(USER,PAT,TEXT,GMRAET) ;Send email to GMRA REQUEST NEW REACTANT indicating user's request for a new allergy
;Returns 0^reason for error
; 1 if successful
N XMDUZ,XMY,XMSUB,GMRATXT,XMTEXT,XMZ,XMMG,GMRAUI,GMRAPI,GMRAUS,GMRAPS,CNT,J
Q:'$G(USER)!('+$G(DUZ))!('$L(TEXT)) "0^Required information missing"
S XMDUZ="Allergy Package",XMSUB="Request to add new reactant"
S XMY("G.GMRA REQUEST NEW REACTANT")=""
S XMY(DUZ)="" ;Include requestor in message
D GETS^DIQ(200,USER,".01;.132;.138;8","E","GMRAUI"),GETS^DIQ(2,PAT,".01;.09","IE","GMRAPI") S GMRAUS=USER_",",GMRAPS=PAT_","
S CNT=1
S GMRATXT(CNT)="A request to add "_TEXT_" as a new reactant was entered",CNT=CNT+1
S GMRATXT(CNT)="by "_GMRAUI(200,GMRAUS,.01,"E")_" for patient "_GMRAPI(2,GMRAPS,.01,"E")_" ("_$E(GMRAPI(2,GMRAPS,.09,"I"),6,9)_")",CNT=CNT+1
S GMRATXT(CNT)="",CNT=CNT+1
S GMRATXT(CNT)="User's contact information:",CNT=CNT+1
S GMRATXT(CNT)="Title : "_GMRAUI(200,GMRAUS,8,"E"),CNT=CNT+1
S GMRATXT(CNT)="Office Phone : "_GMRAUI(200,GMRAUS,.132,"E"),CNT=CNT+1
S GMRATXT(CNT)="Digital Pager: "_GMRAUI(200,GMRAUS,.138,"E"),CNT=CNT+1
S GMRATXT(CNT)="",CNT=CNT+1
I $D(GMRAET) S GMRATXT(CNT)="The user added the following comment:",CNT=CNT+1,GMRATXT(CNT)="",CNT=CNT+1 F J=1:1:$P(GMRAET(0),U,3) S GMRATXT(CNT)=GMRAET(J,0),CNT=CNT+1 ;20 Added blank line following comment
I $D(GMRAET) S GMRATXT(CNT)="",CNT=CNT+1
S GMRATXT(CNT)="Please verify with the user the intended reactant and then take the",CNT=CNT+1
S GMRATXT(CNT)="appropriate action. Be sure to try alternate spellings, etc before",CNT=CNT+1
S GMRATXT(CNT)="requesting new reactants through NTRT (New Term Rapid Turnaround).",CNT=CNT+1 ;23
S GMRATXT(CNT)="",CNT=CNT+1
S GMRATXT(CNT)="Please note, an allergy to "_TEXT_" was NOT entered for this patient!",CNT=CNT+1 ;20
S XMTEXT="GMRATXT("
D ^XMD
Q $S($D(XMMG):"0^Mail group GMRA REQUEST NEW REACTANT has no members - contact IRM",1:1)
;
MESS ;Provide help for sending email message
W !,"Enter YES to send an email to the allergy coordinator(s) indicating that",!,"Reactant--> ",GMRALAR,!,"was not found when you were trying to add it for this patient.",!,"Enter NO to try entering the reactant again."
Q
;
GETINPUT(GMRAET) ;Allow user to add comment to message
N DIC,DWLW,DWPK,DIWEPSE
S ^TMP($J,"TEXT",0)=""
S DIC="^TMP($J,""TEXT"","
S DWLW=70,DWPK=1,DIWEPSE=""
W !!,"You may now add any comments you may have to the message that",!,"is going to be sent with the request to add this reactant."
W !,"You may want to add things like sign/symptoms, observed or historical, etc",!,"that may be useful to the reviewer.",!
D EN^DIWE
I $O(^TMP($J,"TEXT",0)) M GMRAET=^TMP($J,"TEXT")
K ^TMP($J,"TEXT")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAPES0 9405 printed Apr 09, 2024@20:44:17 Page 2
GMRAPES0 ;HIRMFO/RM-SELECT PATIENT ALLERGY TO EDIT ;11/16/07 10:26
+1 ;;4.0;Adverse Reaction Tracking;**13,17,19,21,23,20,41**;Mar 29, 1996;Build 8
+2 ;DBIA Section
+3 ;PSN5067 - 4829
+4 ;DIC - 10006
+5 ;DICN - 10009
+6 ;DIQ - 2056
+7 ;DIR - 10026
+8 ;DIWE - 10028
+9 ;PSNAPIS - 2574
+10 ;PSNDI - 4554
+11 ;XLFDT - 10103
+12 ;XLFSTR - 10104
+13 ;XMD - 10070
+14 ;XTID - 4631
EN1 ; GIVEN DFN, SELECT PATIENT ALLERGY
+1 NEW GMRAGOUT,ROOT,CNT,LST,NAM,DIR,GMRAET
+2 SET GMRARET=0
+3 SET GMRAPA=-1
SET GMRANEW=0
READ !!,"Enter Causative Agent: ",GMRALAR:DTIME
if '$TEST
SET GMRALAR="^^"
if GMRALAR=""
SET GMRARET=1
IF "^^"[GMRALAR
SET GMRAOUT='$LENGTH(GMRALAR)+1
GOTO Q1
+4 IF GMRALAR?1P.E!($LENGTH(GMRALAR)<3)!($LENGTH(GMRALAR)>30)
SET GMRAHLP=1
DO EN1^GMRAHLP0
if 'GMRAOUT
GOTO EN1
GOTO Q1
+5 IF GMRALAR?.E1L.E
SET GMRALAR=$$UP^XLFSTR(GMRALAR)
PAL KILL Y,DTOUT,DUOUT
SET DGSENFLG=""
SET DIC="^GMR(120.8,"
SET DIC(0)="SEZ"
SET X=GMRANAM
SET DIC("S")="I '+$G(^(""ER"")),$P(^(0),U,2)?@(""1""""""_GMRALAR_"""""".E""),$D(^GMR(120.8,""B"",DFN,+Y))"
SET DIC("W")="W $P(^(0),U,2)"
+1 WRITE !!,"Checking existing PATIENT ALLERGIES (#120.8) file for matches...",!
+2 DO ^DIC
SET X=$PIECE($GET(Y(0)),"^",2)
KILL DIC,DGSENFLG,DTOUT,DUOUT
DO DIC
IF GMRAOUT
SET GMRAOUT=GMRAOUT-1
if GMRAOUT
GOTO Q1
GOTO EN1
+3 if +Y>0
SET GMRAPA=+Y
if +Y>0!GMRAOUT
GOTO Q1
if X?1"?".E
GOTO PAL
if Y=0
GOTO EN1
+4 if 'GMRALAGO
GOTO Q1
NPA WRITE !!,"Now checking GMR ALLERGIES (#120.82) file for matches...",!
+1 ;21,23
SET DIC("S")="I $P(^(0),U)'=""OTHER ALLERGY/ADVERSE REACTION""&($S($L($T(SCREEN^XTID)):'$$SCREEN^XTID(120.82,.01,Y_"",""),1:1))"
+2 KILL Y,DTOUT,DUOUT
SET X=GMRALAR
SET DIC="^GMRD(120.82,"
SET DIC(0)="EZM"
SET DIC("W")=""
DO ^DIC
KILL DIC
if +Y>0
SET X=$PIECE(Y,"^",2)
DO DIC
IF GMRAOUT
SET GMRAOUT=GMRAOUT-1
if GMRAOUT
GOTO Q1
GOTO EN1
+3 IF +Y>0
SET GMRAAR=+Y_";GMRD(120.82,"
SET GMRAAR(0)=$PIECE(Y,"^",2)
SET GMRAAR("O")=$PIECE(Y(0),"^",2)
if 'GMRAOUT
DO ADAR^GMRAPES1
if GMRAPA'>0
GOTO EN1
GOTO Q1
+4 if GMRAOUT
GOTO Q1
if X?1"?".E
GOTO NPA
if Y=0
GOTO EN1
NDF ;find partial matches and select from NDF
+1 KILL Y,DTOUT,DUOUT
+2 WRITE !!,"Now checking the National Drug File - Generic Names (#50.6)",!
+3 ;23,41
SET DIC=50.6
SET X=GMRALAR
SET DIC(0)="EZM"
SET DIC("S")="I $S($L($T(SCREEN^XTID)):'$$SCREEN^XTID(50.6,.01,Y_"",""),1:1)"
DO DIC^PSNDI(50.6,"GMRA",.DIC,.X,,$$DT^XLFDT)
KILL DIC
DO DIC
+4 IF +Y>0
SET GMRAAR=+Y_";PSNDF(50.6,"
SET GMRAAR(0)=$PIECE(Y,U,2)
SET GMRAAR("O")="D"
if 'GMRAOUT
DO ADAR^GMRAPES1
if GMRAPA'>0
GOTO EN1
GOTO Q1
+5 WRITE !!,"Now checking the National Drug File - Trade Names (#50.67)",!
+6 KILL DUOUT,DTOUT,Y
+7 ;41
SET ROOT="^TMP($J,""GMRASEL"",""B"")"
SET CNT=0
SET X=GMRALAR
+8 ;41
DO ALL^PSN5067(,X,$$DT^XLFDT,"GMRASEL")
+9 ;23 Exact match stores IEN in 50.6 along with trade name
IF $DATA(@ROOT@(X))
IF $SELECT($LENGTH($TEXT(SCREEN^XTID)):'$$SCREEN^XTID(50.6,.01,$$TGTOG^PSNAPIS(X)_","),1:1)
SET CNT=CNT+1
SET LST(CNT)=$$TGTOG^PSNAPIS(X)_U_X
+10 SET NAM=X
FOR
SET NAM=$ORDER(@ROOT@(NAM))
if NAM=""!($EXTRACT(NAM,1,$LENGTH(X))'=X)
QUIT
Begin DoDot:1
+11 ;23
if $SELECT($LENGTH($TEXT(SCREEN^XTID))
QUIT
+12 SET CNT=CNT+1
SET LST(CNT)=$$TGTOG^PSNAPIS(NAM)_U_NAM
End DoDot:1
+13 ;No matches found
IF 'CNT
SET Y=-1
+14 ;Only one choice
IF CNT=1
SET Y(0)=LST(1)
SET X=$PIECE(Y(0),U,2)
SET Y=+LST(1)
+15 IF CNT>1
Begin DoDot:1
+16 DO MATCHES
+17 SET DIR(0)="NAO^1:"_CNT
SET DIR("A")="Select 1-"_CNT_": "
+18 SET DIR("?")="Select the number of desired causative agent"
+19 DO ^DIR
SET Y=$SELECT(+Y:+Y,1:-1)
if Y>0
SET Y(0)=LST(Y)
SET X=$PIECE(Y(0),U,2)
End DoDot:1
+20 DO DIC
IF GMRAOUT
SET GMRAOUT=GMRAOUT=1
if GMRAOUT
GOTO Q1
GOTO EN1
+21 IF +Y>0
SET GMRAAR=+Y(0)_";PSNDF(50.6,"
SET GMRAAR(0)=$PIECE(Y(0),U,2)
SET GMRAAR("O")="D"
if 'GMRAOUT
DO ADAR^GMRAPES1
if GMRAPA'>0
GOTO EN1
GOTO Q1
+22 ;Selection from file 50 removed in patch 23 and code actually removed in 41
+23 ;19 - Moved ING and CLASS code here
ING WRITE !!,"Now checking the INGREDIENTS (#50.416) file for matches...",!
+1 ;41
KILL Y,DTOUT,DUOUT
SET D="P"
SET DIC="^PS(50.416,"
SET DIC(0)="SEMZ"
SET DIC("S")="I $S($L($T(SCREEN^XTID)):'$$SCREEN^XTID(50.416,.01,Y_"",""),1:1)"
SET X=GMRALAR
DO IX^PSNDI(50.416,"GMRA",.DIC,D,.X,,$$DT^XLFDT)
KILL DIC
DO DIC
+2 ;41
IF GMRAOUT
SET GMRAOUT=GMRAOUT-1
if GMRAOUT
GOTO Q1
GOTO EN1
+3 IF +Y>0
SET GMRAAR=+Y_";PS(50.416,"
SET GMRAAR(0)=$SELECT(X?1A.E:X,1:$PIECE(Y,"^",2))
SET GMRAAR("O")="D"
if 'GMRAOUT
DO ADAR^GMRAPES1
if GMRAPA'>0
GOTO EN1
GOTO Q1
+4 if GMRAOUT
GOTO Q1
if X?1"?".E
GOTO ING
if Y=0
GOTO EN1
CLASS WRITE !!,"Now checking VA DRUG CLASS (50.605) file for matches...",!
+1 ;41
KILL Y,DTOUT,DUOUT
SET X=GMRALAR
SET DIC="^PS(50.605,"
SET DIC(0)="SEZ"
SET D="C"
SET DIC("S")="I $S($L($T(SCREEN^XTID)):'$$SCREEN^XTID(50.605,.01,Y_"",""),1:1)"
DO IX^PSNDI(50.605,"GMRA",.DIC,D,.X,,$$DT^XLFDT)
KILL DIC
DO DIC
+2 ;41
IF GMRAOUT
SET GMRAOUT=GMRAOUT-1
if GMRAOUT
GOTO Q1
GOTO EN1
+3 IF +Y>0
SET GMRAAR=+Y_";PS(50.605,"
SET GMRAAR(0)=$SELECT(X?1A.E:X,1:$PIECE(Y,"^",2))
SET GMRAAR("O")="D"
if 'GMRAOUT
DO ADAR^GMRAPES1
if GMRAPA'>0
GOTO EN1
GOTO Q1
+4 if GMRAOUT
GOTO Q1
if X?1"?".E
GOTO CLASS
if Y=0
GOTO EN1
YNOTH WRITE !!,"Could not find ",GMRALAR," in any files."
+1 WRITE !!,"Before sending an email requesting the addition of a new reactant, please",!,"try entering the first 3 or 4 letters of the reactant to search for",!,"the desired entry.",!
+2 WRITE !,"Would you like to send an email requesting ",GMRALAR,!,"be added as a causative agent?"
+3 SET DIR("A")="Send email"
+4 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("?")="^D MESS^GMRAPES0"
+5 DO ^DIR
+6 IF Y'=+Y
SET GMRAOUT=1
GOTO Q1
+7 IF '+Y
GOTO EN1
YNDRG ;
+1 DO GETINPUT(.GMRAET)
+2 SET X=$$SENDREQ(DUZ,DFN,GMRALAR,.GMRAET)
+3 IF '+X
WRITE !!,"Error - Message not sent - ",$PIECE(X,U,2)
+4 IF +X
WRITE !!,"Message sent - NOTE: This reactant was NOT added for this patient."
+5 WRITE !
Q1 ;
+1 if GMRAPA>0
SET GMRAPA(0)=$SELECT($DATA(^GMR(120.8,+GMRAPA,0)):^(0),1:"")
+2 KILL %,D,DA,DIC,DTOUT,DUOUT,GMRAAR,GMRAHLP,GMRAING,GMRALAGO,GMRALAR,PSNDA,PSODA,X,Y
+3 QUIT
DIC ; VALIDATE LOOKUP FOR A/AR
+1 if $DATA(DTOUT)
SET X="^^"
IF X="^^"
SET GMRAOUT=1
QUIT
+2 if $DATA(DUOUT)
SET Y=0
if +Y'>0
QUIT
YNOK ;19
WRITE !?3,X," OK"
SET %=1
DO YN^DICN
if %=-1
SET GMRAOUT=1
SET Y=-1
if GMRAOUT
QUIT
if %=2
SET Y=-1
if Y=-1
QUIT
if $$DUPCHK(X,DFN,Y)
SET Y=-1
if GMRAOUT
QUIT
IF %
WRITE !
QUIT
+1 WRITE !?5,$CHAR(7),"ANSWER YES IF THIS IS THE CORRECT ALLERGY/ADVERSE REACTION,",!?5,"ELSE ANSWER NO."
+2 GOTO YNOK
DUPCHK(X,Y,Z) ;CHECK FOR ENTERED IN ERROR
+1 NEW GMRAPA,GMRAGOUT,%,%Y
SET GMRAGOUT=0
+2 IF $PIECE($GET(^GMR(120.8,+Z,0)),U,2)=X
QUIT GMRAGOUT
+3 IF $ORDER(^GMR(120.8,"B",Y,0))
SET GMRAPA=0
FOR
SET GMRAPA=$ORDER(^GMR(120.8,"B",Y,GMRAPA))
if GMRAPA<1
QUIT
Begin DoDot:1
+4 IF $PIECE(^GMR(120.8,GMRAPA,0),U,2)'=X
QUIT
+5 IF $DATA(^GMR(120.8,GMRAPA,"ER"))
Begin DoDot:2
+6 FOR
SET %=2
WRITE !,?5,$CHAR(7),"This Agent has been Entered in Error once before.",!,?5,"Are you sure you want to select this Agent again"
Begin DoDot:3
+7 DO YN^DICN
if %'=1
SET %=2
SET GMRAOUT=1
if %Y?2"^"
SET GMRAOUT=2
+8 if %
QUIT
WRITE !,?10,"ENTER 'Y' FOR YES OR 'N' FOR NO"
+9 QUIT
End DoDot:3
if %
QUIT
+10 SET GMRAGOUT=%
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
if GMRAOUT!(GMRAGOUT)
QUIT
+13 IF GMRAGOUT=0
SET GMRAGOUT=1
+14 QUIT (GMRAGOUT-1)
MATCHES ; -- List matches for NDF
+1 NEW I,J,QUIT
+2 WRITE !!,"Choose from the following "_+$GET(CNT)_" matches:"
+3 SET (I,J,QUIT)=0
FOR
SET I=$ORDER(LST(I))
if I'>0
QUIT
Begin DoDot:1
+4 SET J=J+1
IF '(J#(IOSL-5))
if '$$MORE
SET QUIT=1
if QUIT
QUIT
+5 WRITE !,J," ",$PIECE(LST(I),"^",2)
End DoDot:1
if QUIT
QUIT
+6 QUIT
+7 ;
MORE() ; -- show more matches
+1 NEW DIR,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="EA"
SET DIR("A")="Press <return> to see more, or ^ to stop ..."
+3 DO ^DIR
+4 QUIT +Y
+5 ;
SENDREQ(USER,PAT,TEXT,GMRAET) ;Send email to GMRA REQUEST NEW REACTANT indicating user's request for a new allergy
+1 ;Returns 0^reason for error
+2 ; 1 if successful
+3 NEW XMDUZ,XMY,XMSUB,GMRATXT,XMTEXT,XMZ,XMMG,GMRAUI,GMRAPI,GMRAUS,GMRAPS,CNT,J
+4 if '$GET(USER)!('+$GET(DUZ))!('$LENGTH(TEXT))
QUIT "0^Required information missing"
+5 SET XMDUZ="Allergy Package"
SET XMSUB="Request to add new reactant"
+6 SET XMY("G.GMRA REQUEST NEW REACTANT")=""
+7 ;Include requestor in message
SET XMY(DUZ)=""
+8 DO GETS^DIQ(200,USER,".01;.132;.138;8","E","GMRAUI")
DO GETS^DIQ(2,PAT,".01;.09","IE","GMRAPI")
SET GMRAUS=USER_","
SET GMRAPS=PAT_","
+9 SET CNT=1
+10 SET GMRATXT(CNT)="A request to add "_TEXT_" as a new reactant was entered"
SET CNT=CNT+1
+11 SET GMRATXT(CNT)="by "_GMRAUI(200,GMRAUS,.01,"E")_" for patient "_GMRAPI(2,GMRAPS,.01,"E")_" ("_$EXTRACT(GMRAPI(2,GMRAPS,.09,"I"),6,9)_")"
SET CNT=CNT+1
+12 SET GMRATXT(CNT)=""
SET CNT=CNT+1
+13 SET GMRATXT(CNT)="User's contact information:"
SET CNT=CNT+1
+14 SET GMRATXT(CNT)="Title : "_GMRAUI(200,GMRAUS,8,"E")
SET CNT=CNT+1
+15 SET GMRATXT(CNT)="Office Phone : "_GMRAUI(200,GMRAUS,.132,"E")
SET CNT=CNT+1
+16 SET GMRATXT(CNT)="Digital Pager: "_GMRAUI(200,GMRAUS,.138,"E")
SET CNT=CNT+1
+17 SET GMRATXT(CNT)=""
SET CNT=CNT+1
+18 ;20 Added blank line following comment
IF $DATA(GMRAET)
SET GMRATXT(CNT)="The user added the following comment:"
SET CNT=CNT+1
SET GMRATXT(CNT)=""
SET CNT=CNT+1
FOR J=1:1:$PIECE(GMRAET(0),U,3)
SET GMRATXT(CNT)=GMRAET(J,0)
SET CNT=CNT+1
+19 IF $DATA(GMRAET)
SET GMRATXT(CNT)=""
SET CNT=CNT+1
+20 SET GMRATXT(CNT)="Please verify with the user the intended reactant and then take the"
SET CNT=CNT+1
+21 SET GMRATXT(CNT)="appropriate action. Be sure to try alternate spellings, etc before"
SET CNT=CNT+1
+22 ;23
SET GMRATXT(CNT)="requesting new reactants through NTRT (New Term Rapid Turnaround)."
SET CNT=CNT+1
+23 SET GMRATXT(CNT)=""
SET CNT=CNT+1
+24 ;20
SET GMRATXT(CNT)="Please note, an allergy to "_TEXT_" was NOT entered for this patient!"
SET CNT=CNT+1
+25 SET XMTEXT="GMRATXT("
+26 DO ^XMD
+27 QUIT $SELECT($DATA(XMMG):"0^Mail group GMRA REQUEST NEW REACTANT has no members - contact IRM",1:1)
+28 ;
MESS ;Provide help for sending email message
+1 WRITE !,"Enter YES to send an email to the allergy coordinator(s) indicating that",!,"Reactant--> ",GMRALAR,!,"was not found when you were trying to add it for this patient.",!,"Enter NO to try entering the reactant again."
+2 QUIT
+3 ;
GETINPUT(GMRAET) ;Allow user to add comment to message
+1 NEW DIC,DWLW,DWPK,DIWEPSE
+2 SET ^TMP($JOB,"TEXT",0)=""
+3 SET DIC="^TMP($J,""TEXT"","
+4 SET DWLW=70
SET DWPK=1
SET DIWEPSE=""
+5 WRITE !!,"You may now add any comments you may have to the message that",!,"is going to be sent with the request to add this reactant."
+6 WRITE !,"You may want to add things like sign/symptoms, observed or historical, etc",!,"that may be useful to the reviewer.",!
+7 DO EN^DIWE
+8 IF $ORDER(^TMP($JOB,"TEXT",0))
MERGE GMRAET=^TMP($JOB,"TEXT")
+9 KILL ^TMP($JOB,"TEXT")
+10 QUIT
