GMRAVAM0 ;HIRMFO/YMP,WAA,RM-DRIVER FOR VERIFIER ;7/30/04 14:42
;;4.0;Adverse Reaction Tracking;**11,21**;Mar 29, 1996
EN1 ; Entry for VERIFY PATIENT REACTION DATA option
I '$D(^XUSEC("GMRA-ALLERGY VERIFY",DUZ)) G NOVER
EN2 ;Select the type of Agent to verify
S (GMRAOUT,GMRADFN)=0
S DIR("A")="Would you like to verify a single patient's data"
S DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR I $D(DIRUT) K DIRUT G EXIT
;If yes above, D ^DIC on Patient file S GMRADFN=+Y
I Y D G:GMRAOUT EXIT
.W ! S DIC="^DPT(",DIC(0)="AEQM" D ^DIC
.I +Y<1!($D(DUOUT))!($D(DTOUT)) K DIC,DUOUT,DTOUT S GMRAOUT=1 Q
.S GMRADFN=+Y
.K DIC
.Q
D FF
F I="Drug","Non-drug","Both" W !,?20,$E(I,1),?23,I
K DIR S DIR(0)="SOMBA^D:DRUG;N:NON-DRUG;B:BOTH"
S DIR("A")="Select type of AGENT to verify:(D/N/B): "
S DIR("?",1)="ENTER D FOR DRUG AGENTS, N FOR NON-DRUG AGENTS"
S DIR("?")="OR B FOR BOTH DRUG AND NON DRUG AGENTS."
D ^DIR K DIR I "^^"[Y G EXIT
S GMRAFLAG=$S(Y="D":1,Y="N":0,1:2)
K Y
D FF
S GMRAOUT=0 K ^TMP("GMRAV",$J),^TMP("GMRA",$J)
I GMRADFN D VERPT
I 'GMRADFN F GMRADFN=0:0 S GMRADFN=$O(^GMR(120.8,"AVER",GMRADFN)) Q:GMRADFN'>0 D VERPT
I $O(^TMP("GMRAV",$J,""))="" W !,$C(7),"There isn't any ",$S(GMRAFLAG=1:"drug ",GMRAFLAG=0:"non-drug ",1:""),"allergy data to verify.",! G EN1
G DISPLAY
Q
VERPT ; Loop through all Patient GMRADFN's data to be verified and save
; in ^TMP("GMRAV",$J array.
F GMRALL=0:0 S GMRALL=$O(^GMR(120.8,"AVER",GMRADFN,GMRALL)) Q:GMRALL'>0 D ARRAY
Q
ARRAY S GMRAG=$G(^GMR(120.8,GMRALL,0))
S %=$P(GMRAG,U,20),GMRADRUG=$S(%["D"&'(%["F"!(%["O")):1,%'["D":0,1:2)
I GMRAFLAG=2!(GMRADRUG=2)!(GMRAFLAG=GMRADRUG) S ^TMP("GMRAV",$J,$P(^DPT(GMRADFN,0),"^"),$P(GMRAG,"^",2),GMRALL)=GMRAG Q
Q
DISPLAY ;
I GMRAOUT G EXIT
I $O(^TMP("GMRAV",$J,0))="" G EXIT
K GMRADIG D FF
W !,?66,"OBS/"
W !,?4,"PATIENT",?41,"ALLERGY",?66,"HIST",?71,"ADR",?75,"TYPE"
W !,?4,"-------",?41,"-------",?66,"----",?71,"---",?75,"----",!
S GMRANAME="",CX=0 F S GMRANAME=$O(^TMP("GMRAV",$J,GMRANAME)) Q:GMRANAME=""!GMRAOUT S GMRALLER="" D ALLERPR Q:CX<1 I GMRAOUT Q
G:GMRAOUT EXIT
G:$D(GMRADIG) SELL I GMRAOUT G EXIT
SELECT D SEL G:GMRAOUT EXIT
I $D(GMRAY) G:GMRAY="" EXIT
I GMRAOUT G EXIT
SELL F GMRAZ=1:1 S GMRANS=$P(GMRAY,",",GMRAZ) Q:GMRANS<1 Q:GMRAOUT!GMRAER D SELT
K ^TMP("GMRA",$J)
G DISPLAY
SELT ;SELECT THE REACTIONS
D FF
N GMRAY,GMRAZ
S GMRACHK=^TMP("GMRA",$J,GMRANS)
S DFN=$P(GMRACHK,"^",2) D 1^VADPT S GMRALOC=$P(VAIN(4),"^",2),GMRANAM=VADM(1),GMRASEX=VADM(5) D KVAR^VADPT K VA,VAROOT
S GMRADRUG=GMRAFLAG,GMRAOUT=0,GMRAOTH=$O(^GMRD(120.83,"B","OTHER REACTION",0)),GMRAPA=+GMRACHK,GMRAPA(0)=$P(GMRACHK,"^",2,999),GMRAVEDT=0
Q:'$$LOCK^GMRAUTL(120.8,GMRAPA,1)
D SITE^GMRAUTL,EN1^GMRAPEV0 S GMRALL=GMRAPA,GMRADFN=$P(^GMR(120.8,GMRAPA,0),U) D ARRAY
I GMRAVER D EN1^GMRAPET0(GMRADFN,GMRAPA,"V",.GMRAOUT) I GMRAOUT S GMRAOUT=0
I $G(GMRAERR),$G(GMRAOUT) S GMRAOUT=0 ;21
I GMRAERR!GMRAVER S GMRANAME=$P($G(^DPT(+GMRAPA(0),0)),U),GMRALLER=$P(GMRAPA(0),U,2) K:GMRANAME]""&(GMRALLER]"") ^TMP("GMRAV",$J,GMRANAME,GMRALLER,GMRAPA)
D UNLOCK^GMRAUTL(120.8,GMRAPA)
Q
ALLERPR ;
F S GMRALLER=$O(^TMP("GMRAV",$J,GMRANAME,GMRALLER)) Q:GMRALLER=""!GMRAOUT!$D(GMRADIG) F GMRAREC=0:0 S GMRAREC=$O(^TMP("GMRAV",$J,GMRANAME,GMRALLER,GMRAREC)) Q:GMRAREC'>0 D:$Y>(IOSL-5) SCREEN Q:GMRAOUT!$D(GMRADIG) S CX=CX+1 D WRITE
Q
WRITE S GMRAG=^TMP("GMRAV",$J,GMRANAME,GMRALLER,GMRAREC)
S DFN=$P(GMRAG,U) D 1^VADPT S GMRALOC=$P(VAIN(4),"^",2) D PID^VADPT6 S GMRASSN=VA("BID")
D KVAR^VADPT K VA,VAROOT
W !,$J(CX,2),".",?4,$E(GMRANAME,1,20)," (",GMRASSN,") ",$E(GMRALOC,1,8),?41,$E(GMRALLER,1,23),?66
W $S($P(GMRAG,"^",6)="o":"OBS",$P(GMRAG,"^",6)="h":"HIST",1:""),?71,$S($P(GMRAG,"^",14)="A":"NO",$P(GMRAG,"^",14)="P":"YES",1:"UNK")
W ?75 D ;This code is to allow for more than one type.
.N X,GMRAY
.S GMRAY=$P(GMRAG,"^",20)
.F X=1:1:$L(GMRAY) W:X>1 !,?75 W $P("^FOOD^DRUG^OTHER","^",$F("FDO",$E(GMRAY,X)))
.Q
S ^TMP("GMRA",$J,CX)=GMRAREC_"^"_GMRAG
Q
SCREEN W !,"TYPE '^' TO STOP OR"
Q:GMRAOUT D SEL Q:GMRAOUT
I GMRAY="" D FF Q
I GMRAOUT Q
I GMRAER W !?4,$C(7),"ANSWER WITH A NUMBER BETWEEN 1 AND ",CX G SCREEN
S GMRADIG=1
Q
SEL ;
Q:CX<1
K DIR S DIR(0)="LOA^1:"_CX,DIR("A")="Select a number between 1-"_CX_": "
S DIR(0)=DIR(0)_"^I X[""."" W !,""DO NOT USE DECIMAL VALUES."",$C(7) K X Q"
D ^DIR K DIR
S GMRAY=Y K Y
I "^^"[GMRAY S GMRAOUT=$L(GMRAY) Q
S GMRAER=0 F GMRAZ=1:1 S GMRAX=$P(GMRAY,",",GMRAZ) Q:GMRAX<1 D Q:GMRAER
.I '$D(^TMP("GMRA",$J,GMRAX)) W !,"ERROR INVALID SELECTION" S GMRAER=1
.Q
K GMRAX,GMRAZ Q
NOVER ;
W !!?5,$C(7),"You do not have the 'GMRA-ALLERGY VERIFY' Security Key."
EXIT ;
K ^TMP("GMRAV",$J),^TMP("GMRA",$J)
D KILL^XUSCLEAN
Q
FF ;
W #
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAVAM0 4814 printed Dec 13, 2024@01:40:43 Page 2
GMRAVAM0 ;HIRMFO/YMP,WAA,RM-DRIVER FOR VERIFIER ;7/30/04 14:42
+1 ;;4.0;Adverse Reaction Tracking;**11,21**;Mar 29, 1996
EN1 ; Entry for VERIFY PATIENT REACTION DATA option
+1 IF '$DATA(^XUSEC("GMRA-ALLERGY VERIFY",DUZ))
GOTO NOVER
EN2 ;Select the type of Agent to verify
+1 SET (GMRAOUT,GMRADFN)=0
+2 SET DIR("A")="Would you like to verify a single patient's data"
+3 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
KILL DIRUT
GOTO EXIT
+4 ;If yes above, D ^DIC on Patient file S GMRADFN=+Y
+5 IF Y
Begin DoDot:1
+6 WRITE !
SET DIC="^DPT("
SET DIC(0)="AEQM"
DO ^DIC
+7 IF +Y<1!($DATA(DUOUT))!($DATA(DTOUT))
KILL DIC,DUOUT,DTOUT
SET GMRAOUT=1
QUIT
+8 SET GMRADFN=+Y
+9 KILL DIC
+10 QUIT
End DoDot:1
if GMRAOUT
GOTO EXIT
+11 DO FF
+12 FOR I="Drug","Non-drug","Both"
WRITE !,?20,$EXTRACT(I,1),?23,I
+13 KILL DIR
SET DIR(0)="SOMBA^D:DRUG;N:NON-DRUG;B:BOTH"
+14 SET DIR("A")="Select type of AGENT to verify:(D/N/B): "
+15 SET DIR("?",1)="ENTER D FOR DRUG AGENTS, N FOR NON-DRUG AGENTS"
+16 SET DIR("?")="OR B FOR BOTH DRUG AND NON DRUG AGENTS."
+17 DO ^DIR
KILL DIR
IF "^^"[Y
GOTO EXIT
+18 SET GMRAFLAG=$SELECT(Y="D":1,Y="N":0,1:2)
+19 KILL Y
+20 DO FF
+21 SET GMRAOUT=0
KILL ^TMP("GMRAV",$JOB),^TMP("GMRA",$JOB)
+22 IF GMRADFN
DO VERPT
+23 IF 'GMRADFN
FOR GMRADFN=0:0
SET GMRADFN=$ORDER(^GMR(120.8,"AVER",GMRADFN))
if GMRADFN'>0
QUIT
DO VERPT
+24 IF $ORDER(^TMP("GMRAV",$JOB,""))=""
WRITE !,$CHAR(7),"There isn't any ",$SELECT(GMRAFLAG=1:"drug ",GMRAFLAG=0:"non-drug ",1:""),"allergy data to verify.",!
GOTO EN1
+25 GOTO DISPLAY
+26 QUIT
VERPT ; Loop through all Patient GMRADFN's data to be verified and save
+1 ; in ^TMP("GMRAV",$J array.
+2 FOR GMRALL=0:0
SET GMRALL=$ORDER(^GMR(120.8,"AVER",GMRADFN,GMRALL))
if GMRALL'>0
QUIT
DO ARRAY
+3 QUIT
ARRAY SET GMRAG=$GET(^GMR(120.8,GMRALL,0))
+1 SET %=$PIECE(GMRAG,U,20)
SET GMRADRUG=$SELECT(%["D"&'(%["F"!(%["O")):1,%'["D":0,1:2)
+2 IF GMRAFLAG=2!(GMRADRUG=2)!(GMRAFLAG=GMRADRUG)
SET ^TMP("GMRAV",$JOB,$PIECE(^DPT(GMRADFN,0),"^"),$PIECE(GMRAG,"^",2),GMRALL)=GMRAG
QUIT
+3 QUIT
DISPLAY ;
+1 IF GMRAOUT
GOTO EXIT
+2 IF $ORDER(^TMP("GMRAV",$JOB,0))=""
GOTO EXIT
+3 KILL GMRADIG
DO FF
+4 WRITE !,?66,"OBS/"
+5 WRITE !,?4,"PATIENT",?41,"ALLERGY",?66,"HIST",?71,"ADR",?75,"TYPE"
+6 WRITE !,?4,"-------",?41,"-------",?66,"----",?71,"---",?75,"----",!
+7 SET GMRANAME=""
SET CX=0
FOR
SET GMRANAME=$ORDER(^TMP("GMRAV",$JOB,GMRANAME))
if GMRANAME=""!GMRAOUT
QUIT
SET GMRALLER=""
DO ALLERPR
if CX<1
QUIT
IF GMRAOUT
QUIT
+8 if GMRAOUT
GOTO EXIT
+9 if $DATA(GMRADIG)
GOTO SELL
IF GMRAOUT
GOTO EXIT
SELECT DO SEL
if GMRAOUT
GOTO EXIT
+1 IF $DATA(GMRAY)
if GMRAY=""
GOTO EXIT
+2 IF GMRAOUT
GOTO EXIT
SELL FOR GMRAZ=1:1
SET GMRANS=$PIECE(GMRAY,",",GMRAZ)
if GMRANS<1
QUIT
if GMRAOUT!GMRAER
QUIT
DO SELT
+1 KILL ^TMP("GMRA",$JOB)
+2 GOTO DISPLAY
SELT ;SELECT THE REACTIONS
+1 DO FF
+2 NEW GMRAY,GMRAZ
+3 SET GMRACHK=^TMP("GMRA",$JOB,GMRANS)
+4 SET DFN=$PIECE(GMRACHK,"^",2)
DO 1^VADPT
SET GMRALOC=$PIECE(VAIN(4),"^",2)
SET GMRANAM=VADM(1)
SET GMRASEX=VADM(5)
DO KVAR^VADPT
KILL VA,VAROOT
+5 SET GMRADRUG=GMRAFLAG
SET GMRAOUT=0
SET GMRAOTH=$ORDER(^GMRD(120.83,"B","OTHER REACTION",0))
SET GMRAPA=+GMRACHK
SET GMRAPA(0)=$PIECE(GMRACHK,"^",2,999)
SET GMRAVEDT=0
+6 if '$$LOCK^GMRAUTL(120.8,GMRAPA,1)
QUIT
+7 DO SITE^GMRAUTL
DO EN1^GMRAPEV0
SET GMRALL=GMRAPA
SET GMRADFN=$PIECE(^GMR(120.8,GMRAPA,0),U)
DO ARRAY
+8 IF GMRAVER
DO EN1^GMRAPET0(GMRADFN,GMRAPA,"V",.GMRAOUT)
IF GMRAOUT
SET GMRAOUT=0
+9 ;21
IF $GET(GMRAERR)
IF $GET(GMRAOUT)
SET GMRAOUT=0
+10 IF GMRAERR!GMRAVER
SET GMRANAME=$PIECE($GET(^DPT(+GMRAPA(0),0)),U)
SET GMRALLER=$PIECE(GMRAPA(0),U,2)
if GMRANAME]""&(GMRALLER]"")
KILL ^TMP("GMRAV",$JOB,GMRANAME,GMRALLER,GMRAPA)
+11 DO UNLOCK^GMRAUTL(120.8,GMRAPA)
+12 QUIT
ALLERPR ;
+1 FOR
SET GMRALLER=$ORDER(^TMP("GMRAV",$JOB,GMRANAME,GMRALLER))
if GMRALLER=""!GMRAOUT!$DATA(GMRADIG)
QUIT
FOR GMRAREC=0:0
SET GMRAREC=$ORDER(^TMP("GMRAV",$JOB,GMRANAME,GMRALLER,GMRAREC))
if GMRAREC'>0
QUIT
if $Y>(IOSL-5)
DO SCREEN
if GMRAOUT!$DATA(GMRADIG)
QUIT
SET CX=CX+1
DO WRITE
+2 QUIT
WRITE SET GMRAG=^TMP("GMRAV",$JOB,GMRANAME,GMRALLER,GMRAREC)
+1 SET DFN=$PIECE(GMRAG,U)
DO 1^VADPT
SET GMRALOC=$PIECE(VAIN(4),"^",2)
DO PID^VADPT6
SET GMRASSN=VA("BID")
+2 DO KVAR^VADPT
KILL VA,VAROOT
+3 WRITE !,$JUSTIFY(CX,2),".",?4,$EXTRACT(GMRANAME,1,20)," (",GMRASSN,") ",$EXTRACT(GMRALOC,1,8),?41,$EXTRACT(GMRALLER,1,23),?66
+4 WRITE $SELECT($PIECE(GMRAG,"^",6)="o":"OBS",$PIECE(GMRAG,"^",6)="h":"HIST",1:""),?71,$SELECT($PIECE(GMRAG,"^",14)="A":"NO",$PIECE(GMRAG,"^",14)="P":"YES",1:"UNK")
+5 ;This code is to allow for more than one type.
WRITE ?75
Begin DoDot:1
+6 NEW X,GMRAY
+7 SET GMRAY=$PIECE(GMRAG,"^",20)
+8 FOR X=1:1:$LENGTH(GMRAY)
if X>1
WRITE !,?75
WRITE $PIECE("^FOOD^DRUG^OTHER","^",$FIND("FDO",$EXTRACT(GMRAY,X)))
+9 QUIT
End DoDot:1
+10 SET ^TMP("GMRA",$JOB,CX)=GMRAREC_"^"_GMRAG
+11 QUIT
SCREEN WRITE !,"TYPE '^' TO STOP OR"
+1 if GMRAOUT
QUIT
DO SEL
if GMRAOUT
QUIT
+2 IF GMRAY=""
DO FF
QUIT
+3 IF GMRAOUT
QUIT
+4 IF GMRAER
WRITE !?4,$CHAR(7),"ANSWER WITH A NUMBER BETWEEN 1 AND ",CX
GOTO SCREEN
+5 SET GMRADIG=1
+6 QUIT
SEL ;
+1 if CX<1
QUIT
+2 KILL DIR
SET DIR(0)="LOA^1:"_CX
SET DIR("A")="Select a number between 1-"_CX_": "
+3 SET DIR(0)=DIR(0)_"^I X[""."" W !,""DO NOT USE DECIMAL VALUES."",$C(7) K X Q"
+4 DO ^DIR
KILL DIR
+5 SET GMRAY=Y
KILL Y
+6 IF "^^"[GMRAY
SET GMRAOUT=$LENGTH(GMRAY)
QUIT
+7 SET GMRAER=0
FOR GMRAZ=1:1
SET GMRAX=$PIECE(GMRAY,",",GMRAZ)
if GMRAX<1
QUIT
Begin DoDot:1
+8 IF '$DATA(^TMP("GMRA",$JOB,GMRAX))
WRITE !,"ERROR INVALID SELECTION"
SET GMRAER=1
+9 QUIT
End DoDot:1
if GMRAER
QUIT
+10 KILL GMRAX,GMRAZ
QUIT
NOVER ;
+1 WRITE !!?5,$CHAR(7),"You do not have the 'GMRA-ALLERGY VERIFY' Security Key."
EXIT ;
+1 KILL ^TMP("GMRAV",$JOB),^TMP("GMRA",$JOB)
+2 DO KILL^XUSCLEAN
+3 QUIT
FF ;
+1 WRITE #
+2 QUIT
