- GMRAU85 ;HIRMFO/RFM,WAA-UTILITIES FOR FILE 120.85 ; 1/6/93
- ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
- EN1 ; LOOKUP FOR FILE 120.85 ENTRY IF PATIENT IS NOT KNOWN
- ; THEN 120.85 ENTRY (GMRAPA1) IS RETURNED AND GMRAOUT IF ABNORMAL EXIT.
- S GMRAOUT=+($G(GMRAOUT))
- W ! S GMRAPA1=-1,DIC="^DPT(",DIC(0)="AEQM" D ^DIC K DIC G:+Y'>0 Q1 S DFN=+Y,GMRANAM=$P(Y,"^",2)
- D ADR
- I GMRAPA1'>0&'GMRAOUT G EN1
- Q1 ;
- K GMRANAM
- Q
- ADR ; LOOKUP FOR FILE 120.85 ENTRY IF PATIENT (DFN) IS KNOWN,
- ; THEN 120.85 ENTRY (GMRAPA1) IS RETURNED AND GMRAOUT IF ABNORMAL EXIT.
- ;v=New Line
- S X=0,GMRAPA1=-1 F Y=0:0 S Y=$O(^GMR(120.8,"B",DFN,Y)) Q:Y'>0 I $P($G(^GMR(120.8,Y,0)),U,2)]"",$P(^(0),U,20)["D" S X=1 Q
- ;V========= Old Line
- ;S X=0,GMRAPA1=-1 F Y=0:0 S Y=$O(^GMR(120.8,"B",DFN,Y)) Q:Y'>0 I $P($G(^GMR(120.8,Y,0)),U,2)]"",$P(^(0),U,6)="o",$P(^(0),U,20)["D" S X=1 Q
- I 'X W !?4,$C(7),"THIS PATIENT HAS NO ALLERGY/ADVERSE REACTIONS TO REPORT ON." Q
- F D Q:GMRAOUT I +Y>0 S GMRAPA=+Y,GMRAPA(0)=Y(0) Q
- . K DIR S DIR("A")="Select CAUSATIVE AGENT: ",DIR(0)="FAO^1:60",DIR("?",1)=" Answer with a Causative Agent of an observed drug reaction.",DIR("?")=" Type ?? to get a listing of this patient's data."
- . S DIR("??")="^D HLP^GMRAU851" D ^DIR K DIR I $D(DIRUT) S GMRAOUT=1 Q
- . S:GMRAOUT GMRAOUT=GMRAOUT-1
- . S GMRAX=Y,X=$P($G(^DPT(DFN,0)),"^"),DIC="^GMR(120.8,",DIC(0)="EZQ",DIC("S")="I $P(^(0),U)=DFN,$P($$UP^XLFSTR($P(^(0),U,2)),$$UP^XLFSTR(GMRAX))="""",$$OBSDRG^GMRAU85(Y)",DIC("W")="W "" "",$P($G(^(0)),U,2)" D ^DIC K DIC
- . I $D(DTOUT)!$D(DUOUT) S GMRAOUT=1 Q
- . ;S GMRAX=Y,X=GMRAX,DIC="^GMR(120.8,",DIC(0)="SEZQM",DIC("S")="I $P(^(0),U)=DFN,$$OBSDRG^GMRAU85(Y)",DIC("W")="W "" "",$P($G(^(0)),U,2)" D ^DIC K DIC I $D(DTOUT)!$D(DUOUT) S GMRAOUT=1 Q
- . Q
- I GMRAOUT S GMRAOUT=2-GMRAOUT Q
- D EN2
- Q
- EN2 ; LOOKUP 120.85 ENTRY IF PATIENT (DFN) KNOWN, AND 120.8 ENTRY (GMRAPA)
- ; IS KNOWN.
- ; THEN 120.85 ENTRY (GMRAPA1) IS RETURNED AND GMRAOUT IF ABNORMAL EXIT.
- S GMRAPA1=-1
- F D Q:GMRAOUT I +Y>0 S GMRAPA1=+Y Q
- . K DIR S DIR(0)="DO^:NOW:ETX",DIR("A")="Select date reaction was OBSERVED (Time Optional)"
- . S DIR("?",1)=" Please enter the date (time optional) that a reaction to this particular",DIR("?",2)=" causative agent was witnessed.",DIR("?")=" ",DIR("??")="^D HLP1^GMRAU851" D ^DIR K DIR
- . I $D(DIRUT) S GMRAOUT=2 S:$D(DTOUT)!$D(DUOUT) GMRAOUT=1 Q
- . S (X,GMRAX)=Y,DIC=120.85,DIC(0)="EQ"_$S(GMRALAGO:"L",1:"")
- . S DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,15)=GMRAPA" S:GMRALAGO DLAYGO=120.85
- . S DIC("W")="",DIC("DR")=".02////"_DFN_";.03////"_GMRAPA_";1.1///NOW;1.2////"_DUZ D ^DIC K DIC,DLAYGO I $D(DTOUT)!$D(DUOUT) S GMRAOUT=1 Q
- . S GMRAPA1=+Y
- . I '$$LOCK^GMRAUTL(120.85,GMRAPA1,1) S (GMRAPA1,Y)=-1 Q
- . I $P(Y,U,3)=1 S GMRAN85=1 D
- . . ; This code may be of no use anymore after this is change *****
- . . I $O(^GMR(120.8,GMRAPA,10,0)) S ^GMR(120.85,GMRAPA1,2,0)="^120.8502P^"_$P(^GMR(120.8,GMRAPA,10,0),U,3,4),GMRAX=0 F S GMRAX=$O(^GMR(120.8,GMRAPA,10,GMRAX)) Q:GMRAX<1 D
- . . . Q:'$D(^GMR(120.8,GMRAPA,10,GMRAX,0))
- . . . S ^GMR(120.85,GMRAPA1,2,GMRAX,0)=$P(^GMR(120.8,GMRAPA,10,GMRAX,0),U,1,2)_"^"_DUZ
- . . . Q
- . . D:'$G(GMRASITE) SITE^GMRAUTL
- . . I $D(^GMRD(120.84,+GMRASITE,"RPT")) S $P(^GMR(120.85,GMRAPA1,"RPT"),U,1,8)=$P(^GMRD(120.84,+GMRASITE,"RPT"),U,1,8)
- . . S ^GMR(120.85,GMRAPA1,3,0)="^120.8503^1^1"
- . . S ^GMR(120.85,GMRAPA1,3,1,0)=$P(GMRAPA(0),U,2)
- . . S DA=GMRAPA1,DIK="^GMR(120.85," D IX1^DIK
- . . Q
- . Q
- I GMRAOUT S GMRAOUT=2-GMRAOUT
- K GMRAX
- Q
- SCR02 ; SCREEN FOR .02 FIELD OF FILE 120.85
- I $G(DA)<1 Q
- S GMRA=$G(^GMR(120.85,DA,0))
- I $P(GMRA,U,15)<1 K GMRA Q
- I +Y=$P($G(^GMR(120.8,$P(GMRA,U,15),0)),U) K GMRA Q
- I 0
- K GMRA
- Q
- SCR03 ; SCREEN FOR .03 FIELD OF FILE 120.85
- I $G(DA)<1 Q
- S GMRA=$G(^GMR(120.85,DA,0)),GMRA(0)=$G(^GMR(120.8,+Y,0))
- I $P(GMRA(0),U,2)']"" X "I 0" K GMRA Q
- I $P(GMRA,U,2)<1 K GMRA Q
- I $P($G(^GMR(120.8,+Y,0)),U)=$P(GMRA,U,2) K GMRA Q
- I 0
- K GMRA
- Q
- OBSDRG(GMRA) ; GIVEN GMRA AS ENTRY IN 120.8, FUNCTION RETURNS 1 IF OBS. DRUG
- ; ELSE IT RETURNS 0
- I $G(GMRA)="" S GMRA=$P($G(^GMR(120.85,+Y,0)),U,15)
- S GMRA(0)=GMRA,GMRA=$G(^GMR(120.8,+GMRA,0))
- ;v===New Line
- I $P(GMRA,U,20)'["D"!+$G(^GMR(120.8,+GMRA(0),"ER")) S GMRA=0
- ;V===Old Line
- ;I $P(GMRA,U,6)'="o"!($P(GMRA,U,20)'["D")!+$G(^GMR(120.8,+GMRA(0),"ER")) S GMRA=0
- E S GMRA=1
- Q GMRA
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAU85 4482 printed Jan 18, 2025@02:41:48 Page 2
- GMRAU85 ;HIRMFO/RFM,WAA-UTILITIES FOR FILE 120.85 ; 1/6/93
- +1 ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
- EN1 ; LOOKUP FOR FILE 120.85 ENTRY IF PATIENT IS NOT KNOWN
- +1 ; THEN 120.85 ENTRY (GMRAPA1) IS RETURNED AND GMRAOUT IF ABNORMAL EXIT.
- +2 SET GMRAOUT=+($GET(GMRAOUT))
- +3 WRITE !
- SET GMRAPA1=-1
- SET DIC="^DPT("
- SET DIC(0)="AEQM"
- DO ^DIC
- KILL DIC
- if +Y'>0
- GOTO Q1
- SET DFN=+Y
- SET GMRANAM=$PIECE(Y,"^",2)
- +4 DO ADR
- +5 IF GMRAPA1'>0&'GMRAOUT
- GOTO EN1
- Q1 ;
- +1 KILL GMRANAM
- +2 QUIT
- ADR ; LOOKUP FOR FILE 120.85 ENTRY IF PATIENT (DFN) IS KNOWN,
- +1 ; THEN 120.85 ENTRY (GMRAPA1) IS RETURNED AND GMRAOUT IF ABNORMAL EXIT.
- +2 ;v=New Line
- +3 SET X=0
- SET GMRAPA1=-1
- FOR Y=0:0
- SET Y=$ORDER(^GMR(120.8,"B",DFN,Y))
- if Y'>0
- QUIT
- IF $PIECE($GET(^GMR(120.8,Y,0)),U,2)]""
- IF $PIECE(^(0),U,20)["D"
- SET X=1
- QUIT
- +4 ;V========= Old Line
- +5 ;S X=0,GMRAPA1=-1 F Y=0:0 S Y=$O(^GMR(120.8,"B",DFN,Y)) Q:Y'>0 I $P($G(^GMR(120.8,Y,0)),U,2)]"",$P(^(0),U,6)="o",$P(^(0),U,20)["D" S X=1 Q
- +6 IF 'X
- WRITE !?4,$CHAR(7),"THIS PATIENT HAS NO ALLERGY/ADVERSE REACTIONS TO REPORT ON."
- QUIT
- +7 FOR
- Begin DoDot:1
- +8 KILL DIR
- SET DIR("A")="Select CAUSATIVE AGENT: "
- SET DIR(0)="FAO^1:60"
- SET DIR("?",1)=" Answer with a Causative Agent of an observed drug reaction."
- SET DIR("?")=" Type ?? to get a listing of this patient's data."
- +9 SET DIR("??")="^D HLP^GMRAU851"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- SET GMRAOUT=1
- QUIT
- +10 if GMRAOUT
- SET GMRAOUT=GMRAOUT-1
- +11 SET GMRAX=Y
- SET X=$PIECE($GET(^DPT(DFN,0)),"^")
- SET DIC="^GMR(120.8,"
- SET DIC(0)="EZQ"
- SET DIC("S")="I $P(^(0),U)=DFN,$P($$UP^XLFSTR($P(^(0),U,2)),$$UP^XLFSTR(GMRAX))="""",$$OBSDRG^GMRAU85(Y)"
- SET DIC("W")="W "" "",$P($G(^(0)),U,2)"
- DO ^DIC
- KILL DIC
- +12 IF $DATA(DTOUT)!$DATA(DUOUT)
- SET GMRAOUT=1
- QUIT
- +13 ;S GMRAX=Y,X=GMRAX,DIC="^GMR(120.8,",DIC(0)="SEZQM",DIC("S")="I $P(^(0),U)=DFN,$$OBSDRG^GMRAU85(Y)",DIC("W")="W "" "",$P($G(^(0)),U,2)" D ^DIC K DIC I $D(DTOUT)!$D(DUOUT) S GMRAOUT=1 Q
- +14 QUIT
- End DoDot:1
- if GMRAOUT
- QUIT
- IF +Y>0
- SET GMRAPA=+Y
- SET GMRAPA(0)=Y(0)
- QUIT
- +15 IF GMRAOUT
- SET GMRAOUT=2-GMRAOUT
- QUIT
- +16 DO EN2
- +17 QUIT
- EN2 ; LOOKUP 120.85 ENTRY IF PATIENT (DFN) KNOWN, AND 120.8 ENTRY (GMRAPA)
- +1 ; IS KNOWN.
- +2 ; THEN 120.85 ENTRY (GMRAPA1) IS RETURNED AND GMRAOUT IF ABNORMAL EXIT.
- +3 SET GMRAPA1=-1
- +4 FOR
- Begin DoDot:1
- +5 KILL DIR
- SET DIR(0)="DO^:NOW:ETX"
- SET DIR("A")="Select date reaction was OBSERVED (Time Optional)"
- +6 SET DIR("?",1)=" Please enter the date (time optional) that a reaction to this particular"
- SET DIR("?",2)=" causative agent was witnessed."
- SET DIR("?")=" "
- SET DIR("??")="^D HLP1^GMRAU851"
- DO ^DIR
- KILL DIR
- +7 IF $DATA(DIRUT)
- SET GMRAOUT=2
- if $DATA(DTOUT)!$DATA(DUOUT)
- SET GMRAOUT=1
- QUIT
- +8 SET (X,GMRAX)=Y
- SET DIC=120.85
- SET DIC(0)="EQ"_$SELECT(GMRALAGO:"L",1:"")
- +9 SET DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,15)=GMRAPA"
- if GMRALAGO
- SET DLAYGO=120.85
- +10 SET DIC("W")=""
- SET DIC("DR")=".02////"_DFN_";.03////"_GMRAPA_";1.1///NOW;1.2////"_DUZ
- DO ^DIC
- KILL DIC,DLAYGO
- IF $DATA(DTOUT)!$DATA(DUOUT)
- SET GMRAOUT=1
- QUIT
- +11 SET GMRAPA1=+Y
- +12 IF '$$LOCK^GMRAUTL(120.85,GMRAPA1,1)
- SET (GMRAPA1,Y)=-1
- QUIT
- +13 IF $PIECE(Y,U,3)=1
- SET GMRAN85=1
- Begin DoDot:2
- +14 ; This code may be of no use anymore after this is change *****
- +15 IF $ORDER(^GMR(120.8,GMRAPA,10,0))
- SET ^GMR(120.85,GMRAPA1,2,0)="^120.8502P^"_$PIECE(^GMR(120.8,GMRAPA,10,0),U,3,4)
- SET GMRAX=0
- FOR
- SET GMRAX=$ORDER(^GMR(120.8,GMRAPA,10,GMRAX))
- if GMRAX<1
- QUIT
- Begin DoDot:3
- +16 if '$DATA(^GMR(120.8,GMRAPA,10,GMRAX,0))
- QUIT
- +17 SET ^GMR(120.85,GMRAPA1,2,GMRAX,0)=$PIECE(^GMR(120.8,GMRAPA,10,GMRAX,0),U,1,2)_"^"_DUZ
- +18 QUIT
- End DoDot:3
- +19 if '$GET(GMRASITE)
- DO SITE^GMRAUTL
- +20 IF $DATA(^GMRD(120.84,+GMRASITE,"RPT"))
- SET $PIECE(^GMR(120.85,GMRAPA1,"RPT"),U,1,8)=$PIECE(^GMRD(120.84,+GMRASITE,"RPT"),U,1,8)
- +21 SET ^GMR(120.85,GMRAPA1,3,0)="^120.8503^1^1"
- +22 SET ^GMR(120.85,GMRAPA1,3,1,0)=$PIECE(GMRAPA(0),U,2)
- +23 SET DA=GMRAPA1
- SET DIK="^GMR(120.85,"
- DO IX1^DIK
- +24 QUIT
- End DoDot:2
- +25 QUIT
- End DoDot:1
- if GMRAOUT
- QUIT
- IF +Y>0
- SET GMRAPA1=+Y
- QUIT
- +26 IF GMRAOUT
- SET GMRAOUT=2-GMRAOUT
- +27 KILL GMRAX
- +28 QUIT
- SCR02 ; SCREEN FOR .02 FIELD OF FILE 120.85
- +1 IF $GET(DA)<1
- QUIT
- +2 SET GMRA=$GET(^GMR(120.85,DA,0))
- +3 IF $PIECE(GMRA,U,15)<1
- KILL GMRA
- QUIT
- +4 IF +Y=$PIECE($GET(^GMR(120.8,$PIECE(GMRA,U,15),0)),U)
- KILL GMRA
- QUIT
- +5 IF 0
- +6 KILL GMRA
- +7 QUIT
- SCR03 ; SCREEN FOR .03 FIELD OF FILE 120.85
- +1 IF $GET(DA)<1
- QUIT
- +2 SET GMRA=$GET(^GMR(120.85,DA,0))
- SET GMRA(0)=$GET(^GMR(120.8,+Y,0))
- +3 IF $PIECE(GMRA(0),U,2)']""
- XECUTE "I 0"
- KILL GMRA
- QUIT
- +4 IF $PIECE(GMRA,U,2)<1
- KILL GMRA
- QUIT
- +5 IF $PIECE($GET(^GMR(120.8,+Y,0)),U)=$PIECE(GMRA,U,2)
- KILL GMRA
- QUIT
- +6 IF 0
- +7 KILL GMRA
- +8 QUIT
- OBSDRG(GMRA) ; GIVEN GMRA AS ENTRY IN 120.8, FUNCTION RETURNS 1 IF OBS. DRUG
- +1 ; ELSE IT RETURNS 0
- +2 IF $GET(GMRA)=""
- SET GMRA=$PIECE($GET(^GMR(120.85,+Y,0)),U,15)
- +3 SET GMRA(0)=GMRA
- SET GMRA=$GET(^GMR(120.8,+GMRA,0))
- +4 ;v===New Line
- +5 IF $PIECE(GMRA,U,20)'["D"!+$GET(^GMR(120.8,+GMRA(0),"ER"))
- SET GMRA=0
- +6 ;V===Old Line
- +7 ;I $P(GMRA,U,6)'="o"!($P(GMRA,U,20)'["D")!+$G(^GMR(120.8,+GMRA(0),"ER")) S GMRA=0
- +8 IF '$TEST
- SET GMRA=1
- +9 QUIT GMRA