- GMRAPES0 ;HIRMFO/RM-SELECT PATIENT ALLERGY TO EDIT ;07-Jun-2012 17:59;DU
- ;;4.0;Adverse Reaction Tracking;**13,17,19,21,23,20,1002,1003,1005,1006**;Mar 29, 1996;Build 29
- 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...",!
- ;IHS/MSC/MGH mod added back 1006
- ;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
- S DIC("S")="I $P(^(0),U)'=""OTHER ALLERGY/ADVERSE REACTION""&('$$CHECK^GMRAPES0(Y))&($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 K DIC D DIC ;23
- 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=$$T^PSNAPIS,CNT=0,X=GMRALAR
- 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
- DRUG ;W !!,"Now checking the DRUG (#50) file for matches...",! K Y,DTOUT,DUOUT
- ;S CNT=0,X=GMRALAR K LST
- ;F ROOT="^PSDRUG(""B"")","^PSDRUG(""C"")" D
- ;.I $D(@ROOT@(X)) S CNT=CNT+1,LST(CNT)=$O(@ROOT@(X,0))_U_$S(ROOT["C":$$GET1^DIQ(50,$O(@ROOT@(X,0)),.01)_" <"_X_">",1:X)
- ;.S NAM=X F S NAM=$O(@ROOT@(NAM)) Q:NAM=""!($E(NAM,1,$L(X))'=X) D
- ;..S CNT=CNT+1,LST(CNT)=$O(@ROOT@(NAM,0))_U_$S(ROOT["C":$$GET1^DIQ(50,$O(@ROOT@(NAM,0)),.01)_" <"_NAM_">",1: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)_";PSDRUG(",GMRAAR(0)=$$GET1^DIQ(50,+Y(0),.01),GMRAAR("O")="D" D:'GMRAOUT ADAR^GMRAPES1 G EN1:GMRAPA'>0,Q1
- ;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^DIC K DIC D DIC I GMRAOUT S GMRAOUT=GMRAOUT-1 G:GMRAOUT Q1 G EN1
- 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^DIC K DIC D DIC I GMRAOUT S GMRAOUT=GMRAOUT-1 G:GMRAOUT Q1 G EN1
- 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. If this reactant does require review for",CNT=CNT+1 ;23
- S GMRATXT(CNT)="addition, please submit through the IHS RPMS Feedback page at",CNT=CNT+1 ;1002
- S GMRATXT(CNT)="http://www.ihs.gov/RPMS using the RPMS Application 'Pharmacy-New Reactant/",CNT=CNT+1
- S GMRATXT(CNT)="Symptom Request(PRSR)'",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
- CHECK(ORIEN) ;Check to see if allergy is active)
- N VALUE,STAT,STATUS
- S VALUE=0
- ;IHS/MSC/MGH Updated patch 1005 to loop by date
- S TERMDT=$O(^GMRD(120.82,ORIEN,"TERMSTATUS","B",$C(0)),-1) I TERMDT'="" D
- .S STAT=$O(^GMRD(120.82,ORIEN,"TERMSTATUS",$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
- GMRAPES0 ;HIRMFO/RM-SELECT PATIENT ALLERGY TO EDIT ;07-Jun-2012 17:59;DU
- +1 ;;4.0;Adverse Reaction Tracking;**13,17,19,21,23,20,1002,1003,1005,1006**;Mar 29, 1996;Build 29
- 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 ;IHS/MSC/MGH mod added back 1006
- +2 ;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
- +3 ;21,23
- SET DIC("S")="I $P(^(0),U)'=""OTHER ALLERGY/ADVERSE REACTION""&('$$CHECK^GMRAPES0(Y))&($S($L($T(SCREEN^XTID)):'$$SCREEN^XTID(120.82,.01,Y_"",""),1:1))"
- +4 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
- +5 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
- +6 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
- 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
- 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 SET ROOT=$$T^PSNAPIS
- SET CNT=0
- SET X=GMRALAR
- +8 ;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
- +9 SET NAM=X
- FOR
- SET NAM=$ORDER(@ROOT@(NAM))
- IF NAM=""!($EXTRACT(NAM,1,$LENGTH(X))'=X)
- QUIT
- Begin DoDot:1
- +10 ;23
- IF $SELECT($LENGTH($TEXT(SCREEN^XTID))
- QUIT
- +11 SET CNT=CNT+1
- SET LST(CNT)=$$TGTOG^PSNAPIS(NAM)_U_NAM
- End DoDot:1
- +12 ;No matches found
- IF 'CNT
- SET Y=-1
- +13 ;Only one choice
- IF CNT=1
- SET Y(0)=LST(1)
- SET X=$PIECE(Y(0),U,2)
- SET Y=+LST(1)
- +14 IF CNT>1
- Begin DoDot:1
- +15 DO MATCHES
- +16 SET DIR(0)="NAO^1:"_CNT
- SET DIR("A")="Select 1-"_CNT_": "
- +17 SET DIR("?")="Select the number of desired causative agent"
- +18 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
- +19 DO DIC
- IF GMRAOUT
- SET GMRAOUT=GMRAOUT=1
- IF GMRAOUT
- GOTO Q1
- GOTO EN1
- +20 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
- +21 ;Selection from file 50 removed in patch 23
- DRUG ;W !!,"Now checking the DRUG (#50) file for matches...",! K Y,DTOUT,DUOUT
- +1 ;S CNT=0,X=GMRALAR K LST
- +2 ;F ROOT="^PSDRUG(""B"")","^PSDRUG(""C"")" D
- +3 ;.I $D(@ROOT@(X)) S CNT=CNT+1,LST(CNT)=$O(@ROOT@(X,0))_U_$S(ROOT["C":$$GET1^DIQ(50,$O(@ROOT@(X,0)),.01)_" <"_X_">",1:X)
- +4 ;.S NAM=X F S NAM=$O(@ROOT@(NAM)) Q:NAM=""!($E(NAM,1,$L(X))'=X) D
- +5 ;..S CNT=CNT+1,LST(CNT)=$O(@ROOT@(NAM,0))_U_$S(ROOT["C":$$GET1^DIQ(50,$O(@ROOT@(NAM,0)),.01)_" <"_NAM_">",1:NAM)
- +6 ;I 'CNT S Y=-1 ;No matches found
- +7 ;I CNT=1 S Y(0)=LST(1),X=$P(Y(0),U,2),Y=+LST(1) ;Only one choice
- +8 ;I CNT>1 D
- +9 ;.D MATCHES
- +10 ;.S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": "
- +11 ;.S DIR("?")="Select the number of desired causative agent"
- +12 ;.D ^DIR S Y=$S(+Y:+Y,1:-1) S:Y>0 Y(0)=LST(Y),X=$P(Y(0),U,2)
- +13 ;D DIC I GMRAOUT S GMRAOUT=GMRAOUT-1 G:GMRAOUT Q1 G EN1
- +14 ;I +Y>0 S GMRAAR=+Y(0)_";PSDRUG(",GMRAAR(0)=$$GET1^DIQ(50,+Y(0),.01),GMRAAR("O")="D" D:'GMRAOUT ADAR^GMRAPES1 G EN1:GMRAPA'>0,Q1
- +15 ;19 - Moved ING and CLASS code here
- ING WRITE !!,"Now checking the INGREDIENTS (#50.416) file for matches...",!
- +1 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^DIC
- KILL DIC
- DO DIC
- IF GMRAOUT
- SET GMRAOUT=GMRAOUT-1
- IF GMRAOUT
- GOTO Q1
- GOTO EN1
- +2 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
- +3 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 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^DIC
- KILL DIC
- DO DIC
- IF GMRAOUT
- SET GMRAOUT=GMRAOUT-1
- IF GMRAOUT
- GOTO Q1
- GOTO EN1
- +2 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
- +3 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. If this reactant does require review for"
- SET CNT=CNT+1
- +23 ;1002
- SET GMRATXT(CNT)="addition, please submit through the IHS RPMS Feedback page at"
- SET CNT=CNT+1
- +24 SET GMRATXT(CNT)="http://www.ihs.gov/RPMS using the RPMS Application 'Pharmacy-New Reactant/"
- SET CNT=CNT+1
- +25 SET GMRATXT(CNT)="Symptom Request(PRSR)'"
- SET CNT=CNT+1
- +26 ;20
- SET GMRATXT(CNT)="Please note, an allergy to "_TEXT_" was NOT entered for this patient!"
- SET CNT=CNT+1
- +27 SET XMTEXT="GMRATXT("
- +28 DO ^XMD
- +29 QUIT $SELECT($DATA(XMMG):"0^Mail group GMRA REQUEST NEW REACTANT has no members - contact IRM",1:1)
- +30 ;
- 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
- CHECK(ORIEN) ;Check to see if allergy is active)
- +1 NEW VALUE,STAT,STATUS
- +2 SET VALUE=0
- +3 ;IHS/MSC/MGH Updated patch 1005 to loop by date
- +4 SET TERMDT=$ORDER(^GMRD(120.82,ORIEN,"TERMSTATUS","B",$CHAR(0)),-1)
- IF TERMDT'=""
- Begin DoDot:1
- +5 SET STAT=$ORDER(^GMRD(120.82,ORIEN,"TERMSTATUS",$CHAR(0)),-1)
- IF STAT'=""
- Begin DoDot:2
- +6 SET STATUS=$PIECE($GET(^GMRD(120.82,ORIEN,"TERMSTATUS",STAT,0)),U,2)
- +7 IF STATUS=0
- SET VALUE=1
- End DoDot:2
- End DoDot:1
- +8 QUIT VALUE
