GMRAFX2 ;SLC/DAN Select reactant for update ;01-May-2012 14:17;DU
;;4.0;Adverse Reaction Tracking;**17,19,21,23,1002,1006**;Mar 29, 1996;Build 29
;DBIA SECTION
;10026 - DIR
;2056 - DIQ
;221 - PSDRUG("B", and PSDRUG("C", cross references
;10104 - XLFSTR
;10006 - DIC
;2531 - $$T^PSNAPIS
;2574 - $$TGTOG^PSNAPIS
;
EN1 ; Select new reactant
N DIR,Y,DIRUT,X,DTOUT,DUOUT,DIC,GMRALAR,D,ENTRY,OK,CNT,LST,ROOT,NAM,DIROUT
S DIR(0)="FO^3:30",DIR("A")="Enter Causative Agent",DIR("?")="^D HELP^GMRAFX2" D ^DIR S:$D(DIROUT) STOP=1 Q:$D(DIRUT) S GMRALAR=$$UP^XLFSTR(Y)
;IHS/MSC/MGH mod returned patch 1006
NPA 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
;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
W !!,"Checking GMR ALLERGIES (#120.82) file for matches...",! K Y,DTOUT,DUOUT,ENTRY S X=GMRALAR,DIC="^GMRD(120.82,",DIC(0)="EZM",DIC("W")="" D ^DIC K DIC S:+Y>0 ENTRY=X D DIC ;21
I +Y>0&($G(OK)) S GMRAAR=+Y_";GMRD(120.82,",GMRAAR(0)=$P(Y,"^",2),GMRAAR("O")=$P(Y(0),"^",2) Q
NDF ;find partial matches and select from NDF
K Y,DTOUT,DUOUT,ENTRY
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 S:+Y>0 ENTRY=X D DIC ;23
I +Y>0&($G(OK)) S GMRAAR=+Y_";PSNDF(50.6,",GMRAAR(0)=$P(Y,U,2),GMRAAR("O")="D" Q
W !!,"Now checking the National Drug File - Trade Names (#50.67)",!
K DUOUT,DTOUT,Y,ENTRY
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),ENTRY=$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),(ENTRY,X)=$P(Y(0),U,2)
D DIC
I +Y>0&($G(OK)) S GMRAAR=+Y(0)_";PSNDF(50.6,",GMRAAR(0)=$P(Y(0),U,2),GMRAAR("O")="D" Q
;Selection from file 50 removed in patch 23
DRUG ;W !!,"Now checking the DRUG (#50) file for matches...",! K Y,DTOUT,DUOUT,ENTRY
;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) ;Exact match stores IEN in 50
;.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),ENTRY=$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),(ENTRY,X)=$P(Y(0),U,2)
;D DIC
;I +Y>0&($G(OK)) S GMRAAR=+Y(0)_";PSDRUG(",GMRAAR(0)=$$GET1^DIQ(50,+Y(0),.01),GMRAAR("O")="D" Q
;19 - Moved ING and CLASS code here from above
ING W !!,"Now checking INGREDIENT (#50.416) file for matches...",! ;23
K Y,DTOUT,DUOUT,ENTRY 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 S:+Y>0 ENTRY=X D DIC ;23
I +Y>0&($G(OK)) S GMRAAR=+Y_";PS(50.416,",GMRAAR(0)=$S(X?1A.E:X,1:$P(Y,"^",2)),GMRAAR("O")="D" Q
CLASS W !!,"Now checking VA DRUG CLASS (#50.605) file for matches...",! ;23
K Y,DTOUT,DUOUT,ENTRY S X=GMRALAR,DIC="^PS(50.605,",DIC(0)="SEZ",DIC("S")="I $S($L($T(SCREEN^XTID)):'$$SCREEN^XTID(50.605,.01,Y_"",""),1:1)",D="C" D IX^DIC K DIC S:+Y>0 ENTRY=X D DIC ;23
I +Y>0&($G(OK)) S GMRAAR=+Y_";PS(50.605,",GMRAAR(0)=$S(X?1A.E:X,1:$P(Y,"^",2)),GMRAAR("O")="D" Q
YNOTH W !!,"Could not find ",GMRALAR," in any files.",!,"Please try again (check spelling, etc).",!,"If you need to add a new reactant, use the AE option." G EN1
Q
DIC ; VALIDATE LOOKUP FOR A/AR
N DIR,X,Y
Q:'$D(ENTRY)
K OK
W !!,"You selected ",ENTRY
S DIR(0)="Y",DIR("B")="Y",DIR("A")="Is this correct",DIR("?")="Answer yes if this is the correct reactant" D ^DIR S:Y=1 OK=1
Q
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
;
HELP ;Display help for selection of causative agent
W !,"Enter new causative agent to be assigned to the selected entries."
W !,"Enter between 3 and 30 characters. The entered text will then be"
W !,"searched for in a number of different files. Select the appropriate"
W !,"entry from the appropriate file to update the selected patient."
W !!,"Enter ^ to skip the current patient or ^^ to exit the entire process."
Q
GMRAFX2 ;SLC/DAN Select reactant for update ;01-May-2012 14:17;DU
+1 ;;4.0;Adverse Reaction Tracking;**17,19,21,23,1002,1006**;Mar 29, 1996;Build 29
+2 ;DBIA SECTION
+3 ;10026 - DIR
+4 ;2056 - DIQ
+5 ;221 - PSDRUG("B", and PSDRUG("C", cross references
+6 ;10104 - XLFSTR
+7 ;10006 - DIC
+8 ;2531 - $$T^PSNAPIS
+9 ;2574 - $$TGTOG^PSNAPIS
+10 ;
EN1 ; Select new reactant
+1 NEW DIR,Y,DIRUT,X,DTOUT,DUOUT,DIC,GMRALAR,D,ENTRY,OK,CNT,LST,ROOT,NAM,DIROUT
+2 SET DIR(0)="FO^3:30"
SET DIR("A")="Enter Causative Agent"
SET DIR("?")="^D HELP^GMRAFX2"
DO ^DIR
IF $DATA(DIROUT)
SET STOP=1
IF $DATA(DIRUT)
QUIT
SET GMRALAR=$$UP^XLFSTR(Y)
+3 ;IHS/MSC/MGH mod returned patch 1006
NPA ;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))"
+1 ;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
+2 ;21
WRITE !!,"Checking GMR ALLERGIES (#120.82) file for matches...",!
KILL Y,DTOUT,DUOUT,ENTRY
SET X=GMRALAR
SET DIC="^GMRD(120.82,"
SET DIC(0)="EZM"
SET DIC("W")=""
DO ^DIC
KILL DIC
IF +Y>0
SET ENTRY=X
DO DIC
+3 IF +Y>0&($GET(OK))
SET GMRAAR=+Y_";GMRD(120.82,"
SET GMRAAR(0)=$PIECE(Y,"^",2)
SET GMRAAR("O")=$PIECE(Y(0),"^",2)
QUIT
NDF ;find partial matches and select from NDF
+1 KILL Y,DTOUT,DUOUT,ENTRY
+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
IF +Y>0
SET ENTRY=X
DO DIC
+4 IF +Y>0&($GET(OK))
SET GMRAAR=+Y_";PSNDF(50.6,"
SET GMRAAR(0)=$PIECE(Y,U,2)
SET GMRAAR("O")="D"
QUIT
+5 WRITE !!,"Now checking the National Drug File - Trade Names (#50.67)",!
+6 KILL DUOUT,DTOUT,Y,ENTRY
+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 ENTRY=$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 (ENTRY,X)=$PIECE(Y(0),U,2)
End DoDot:1
+19 DO DIC
+20 IF +Y>0&($GET(OK))
SET GMRAAR=+Y(0)_";PSNDF(50.6,"
SET GMRAAR(0)=$PIECE(Y(0),U,2)
SET GMRAAR("O")="D"
QUIT
+21 ;Selection from file 50 removed in patch 23
DRUG ;W !!,"Now checking the DRUG (#50) file for matches...",! K Y,DTOUT,DUOUT,ENTRY
+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) ;Exact match stores IEN in 50
+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),ENTRY=$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),(ENTRY,X)=$P(Y(0),U,2)
+13 ;D DIC
+14 ;I +Y>0&($G(OK)) S GMRAAR=+Y(0)_";PSDRUG(",GMRAAR(0)=$$GET1^DIQ(50,+Y(0),.01),GMRAAR("O")="D" Q
+15 ;19 - Moved ING and CLASS code here from above
ING ;23
WRITE !!,"Now checking INGREDIENT (#50.416) file for matches...",!
+1 ;23
KILL Y,DTOUT,DUOUT,ENTRY
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
IF +Y>0
SET ENTRY=X
DO DIC
+2 IF +Y>0&($GET(OK))
SET GMRAAR=+Y_";PS(50.416,"
SET GMRAAR(0)=$SELECT(X?1A.E:X,1:$PIECE(Y,"^",2))
SET GMRAAR("O")="D"
QUIT
CLASS ;23
WRITE !!,"Now checking VA DRUG CLASS (#50.605) file for matches...",!
+1 ;23
KILL Y,DTOUT,DUOUT,ENTRY
SET X=GMRALAR
SET DIC="^PS(50.605,"
SET DIC(0)="SEZ"
SET DIC("S")="I $S($L($T(SCREEN^XTID)):'$$SCREEN^XTID(50.605,.01,Y_"",""),1:1)"
SET D="C"
DO IX^DIC
KILL DIC
IF +Y>0
SET ENTRY=X
DO DIC
+2 IF +Y>0&($GET(OK))
SET GMRAAR=+Y_";PS(50.605,"
SET GMRAAR(0)=$SELECT(X?1A.E:X,1:$PIECE(Y,"^",2))
SET GMRAAR("O")="D"
QUIT
YNOTH WRITE !!,"Could not find ",GMRALAR," in any files.",!,"Please try again (check spelling, etc).",!,"If you need to add a new reactant, use the AE option."
GOTO EN1
+1 QUIT
DIC ; VALIDATE LOOKUP FOR A/AR
+1 NEW DIR,X,Y
+2 IF '$DATA(ENTRY)
QUIT
+3 KILL OK
+4 WRITE !!,"You selected ",ENTRY
+5 SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Is this correct"
SET DIR("?")="Answer yes if this is the correct reactant"
DO ^DIR
IF Y=1
SET OK=1
+6 QUIT
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 ;
HELP ;Display help for selection of causative agent
+1 WRITE !,"Enter new causative agent to be assigned to the selected entries."
+2 WRITE !,"Enter between 3 and 30 characters. The entered text will then be"
+3 WRITE !,"searched for in a number of different files. Select the appropriate"
+4 WRITE !,"entry from the appropriate file to update the selected patient."
+5 WRITE !!,"Enter ^ to skip the current patient or ^^ to exit the entire process."
+6 QUIT
