GMRAUTL2 ;SLC/DAN New style index utilities, update utility for 120.8 ;21-Jun-2012 08:36;DU
;;4.0;Adverse Reaction Tracking;**23,36,1005,1006**;Mar 29, 1996;Build 29
;
N GMRAI,GMRAC,ENTRY,UPDATED
Q:$G(X1(1))=$G(X2(1)) ;Entry unchanged
S ENTRY=DA(1)_";GMRD(120.82,"_"^"_$P(^GMRD(120.82,DA(1),0),"^")
I $G(X1(1))>0,$G(X2(1))>0 S:$G(GMRAT)="ING" GMRAI("D",X1(1))="",GMRAI("A",X2(1))="" S:$G(GMRAT)="CLASS" GMRAC("D",X1(1))="",GMRAC("A",X2(1))="" ;Edited existing entry
I $G(X1(1))>0,$G(X2(1))="" S:$G(GMRAT)="ING" GMRAI("D",X1(1))="" S:$G(GMRAT)="CLASS" GMRAC("D",X1(1))="" ;Entry deleted
I $G(X1(1))="",$G(X2(1))>0 S:$G(GMRAT)="ING" GMRAI("A",X2(1))="" S:$G(GMRAT)="CLASS" GMRAC("A",X2(1))="" ;New entry
D QUP ;Queue updating of existing entries and order checking
Q
;
QUP ;Queue the update
S ZTRTN="UPDATE^GMRAUTL2(ENTRY,.GMRAI,.GMRAC)",ZTIO="GMRA UPDATE RESOURCE",ZTDTH=$H,ZTDESC="Update existing allergies",ZTSAVE("*")="" D ^%ZTLOAD Q
;
UPDATE(ENTRY,ING,CLASS) ;Update existing entries in 120.8 with new information.
;Entry is IEN;File reference^Text of file entry - 6;GMRD(120.82,^STRAWBERRIES
;ING - Array of ingredients - "A",IEN for those to be added and "D",IEN for those to be deleted
;CLASS - Array of drug classes - "A",IEN for those to be added and "D",IEN for those to be deleted
;
N ALLERGY,POINTER,ACTION,SUB,SUBI,SUBC,DFN,GMRAS,GMRACOM
S ALLERGY=$P(ENTRY,"^",2) Q:ALLERGY=""
S POINTER=$P(ENTRY,"^") Q:POINTER=""
S SUB=0 F S SUB=$O(^GMR(120.8,"C",ALLERGY,SUB)) Q:'+SUB D
.S DFN=$P(^GMR(120.8,SUB,0),U)
.Q:$$DECEASED^GMRAFX(DFN) ;Don't update if patient is deceased
.Q:$P(^GMR(120.8,SUB,0),"^",3)'=POINTER ;Same text name but not the same entry
.Q:$G(^GMR(120.8,SUB,"ER"))>0 ;Entered in error
.S GMRACOM=0
.F ACTION="A","D" D
..S SUBI=0 F S SUBI=$O(ING(ACTION,SUBI)) Q:'+SUBI D
...I ACTION="A" D ADD("I",SUB,SUBI,.GMRAS) I $G(GMRAS) S ING(ACTION,SUBI)=1,GMRACOM=1,UPDATED(DFN)=""
...I ACTION="D" D DEL("I",SUB,SUBI,.GMRAS) I $G(GMRAS) S ING(ACTION,SUBI)=1,GMRACOM=1
..S SUBC=0 F S SUBC=$O(CLASS(ACTION,SUBC)) Q:'+SUBC D
...I ACTION="A" D ADD("C",SUB,SUBC,.GMRAS) I $G(GMRAS) S CLASS(ACTION,SUBC)=1,UPDATED(DFN)="",GMRACOM=1
...I ACTION="D" D DEL("C",SUB,SUBC,.GMRAS) I $G(GMRAS) S GMRACOM=1,CLASS(ACTION,SUBC)=1
.I $G(GMRACOM) D ADDCOM
I $D(UPDATED) D CHKORD ;New order checks now?
Q
;
ADD(TYPE,ALENT,SUBENT,GMRAS) ;Adds entry to appropriate multiple
N FILE,FDA,EM
S GMRAS=1
I $D(^GMR(120.8,ALENT,$S(TYPE="I":2,1:3),"B",SUBENT)) S GMRAS=0 Q ;Entry already exists
L +^GMR(120.8,ALENT)
S FILE=$S(TYPE="I":120.802,1:120.803)
S FDA(FILE,"+1,"_ALENT_",",.01)=SUBENT
D UPDATE^DIE("","FDA",,"EM")
L -^GMR(120.8,ALENT)
Q
;
DEL(TYPE,ALENT,SUBENT,GMRAS) ;Delete entry from multiple
N FILE,FDA,EM,ENTRY
S GMRAS=1
I '$D(^GMR(120.8,ALENT,$S(TYPE="I":2,1:3),"B",SUBENT)) S GMRAS=0 Q ;No entry to delete
L +^GMR(120.8,ALENT)
S ENTRY=$O(^GMR(120.8,ALENT,$S(TYPE="I":2,1:3),"B",SUBENT,0)) Q:'+ENTRY
S FILE=$S(TYPE="I":120.802,1:120.803)
S FDA(FILE,ENTRY_","_ALENT_",",.01)="@"
D FILE^DIE("","FDA","EM")
L -^GMR(120.8,ALENT)
Q
;
CHKORD ;Check for orders that are now in conflict with existing allergy data
N TIME,GMRAOC,ORX,SUB,GMRAORX,GI,CNT,DFN
Q:'+$G(DUZ) ;Don't check if no valid user to send data to
K ^TMP("ORR",$J),^TMP($J,"ERR")
S DFN=0 F S DFN=$O(UPDATED(DFN)) Q:'+DFN D
.D EN^ORQ1(DFN_";DPT(") ;Retrieve active orders
.S TIME=$O(^TMP("ORR",$J,0))
.Q:'^TMP("ORR",$J,TIME,"TOT") ;No orders found
.S SUB=0 F S SUB=$O(^TMP("ORR",$J,TIME,SUB)) Q:'+SUB D
..D BLD^ORCHECK(+^TMP("ORR",$J,TIME,SUB)) ;Get "order" information in order checking format
.M GMRAORX=ORX K ORX,GMRAOC
.D EN^ORKCHK(.GMRAOC,DFN,.GMRAORX,"ACCEPT")
.S GI=0,CNT=0 F S GI=$O(GMRAOC(GI)) Q:'+GI D
..Q:$P(GMRAOC(GI),U,2)'=3 ;Quit if not allergy related
..Q:$D(^OR(100,$P(GMRAOC(GI),U),9,"B",3)) ;Quit if existing allergy order check, can't be for this new information
..S CNT=CNT+1,^TMP($J,"ERR",DFN,CNT)=$P($$STATUS^ORQOR2($P(GMRAOC(GI),U)),U,2)_" order for "_$P($$OI^ORX8($P(GMRAOC(GI),U)),U,2)_",order #"_$P(GMRAOC(GI),U)
.K GMRAORX ;Remove previous list of orders
D MAIL K ^TMP("ORR",$J),^TMP($J,"ERR")
Q
;
ADDCOM ;Add comment to updated allergy indicating changes
Q
N TYPE,ROOT,SUB2,DICR,DIEL,DL,DP,DM,DK,DIK,DC,DE,GLOB,DH,D,DQ,DR,DIC,DIE,DIA,DI,DG,DDH,DDER,DA,D0,D1
F GLOB="ING(""A"")","ING(""D"")","CLASS(""A"")","CLASS(""D"")" I $D(@GLOB) D
.S TYPE=$S(GLOB="ING(""A"")":1,GLOB="ING(""D"")":2,GLOB="CLASS(""A"")":3,1:4) ;Determines if we're adding or deleting ingredients or classes
.S COM="The following "_$S(TYPE=1!(TYPE=2):"ingredients",1:"drug classes")_" were "_$S(TYPE=2!(TYPE=4):"deleted",1:"added")_": "
.S ROOT=$S(TYPE=1:"ING(""A"")",TYPE=2:"ING(""D"")",TYPE=3:"CLASS(""A"")",1:"CLASS(""D"")")
.S SUB2=0 F S SUB2=$O(@ROOT@(SUB2)) Q:'+SUB2 I @ROOT@(SUB2) S COM=COM_$S($P(COM,": ",2)'="":", ",1:"")_$S(TYPE=1!(TYPE=2):$$GET1^DIQ(50.416,SUB2_",",.01),1:$$GET1^DIQ(50.605,SUB2_",",.01))
.I $P(COM,": ",2)'="" L +^GMR(120.8,SUB) D ADCOM^GMRAFX(SUB,"O",COM) L -^GMR(120.8,SUB)
Q
;
MAIL ;Send message containing potential order checks to user.
N XMSUB,XMTEXT,XMDUZ,XMY,XMZ,CNT,SUB,ERR,TYPE,NUM
Q:'$D(^TMP($J,"ERR")) ;Nothing to report
K ^TMP($J,"TEXT")
S XMDUZ="Allergy auto-update program"
S XMY($G(DUZ,.5))="" ;Send to user who initiated change or postmaster
S XMY("G.GMRA REQUEST NEW REACTANT")="" ;Include mail group to be sure someone gets this message
S CNT=1
S ^TMP($J,"TEXT",CNT)="The "_$P(ENTRY,U,2)_" reactant was updated.",CNT=CNT+1
S ^TMP($J,"TEXT",CNT)="The following drug classes and/or drug ingredients were added:",CNT=CNT+1,^TMP($J,"TEXT",CNT)="",CNT=CNT+1
F TYPE="GMRAI","GMRAC" D
.I $D(@(TYPE)) D
..S ^TMP($J,"TEXT",CNT)=$S(TYPE="GMRAI":"Ingredients",1:"Classes")_": ",CNT=CNT+1
..S NUM=0 F S NUM=$O(@TYPE@("A",NUM)) Q:'+NUM S ^TMP($J,"TEXT",CNT)=$G(^TMP($J,"TEXT",CNT))_$S($L($G(^TMP($J,"TEXT",CNT))):",",1:"")_$$GET1^DIQ($S(TYPE="GMRAI":50.416,1:50.605),NUM_",",.01)
..S CNT=CNT+1,^TMP($J,"TEXT",CNT)="",CNT=CNT+1
S ^TMP($J,"TEXT",CNT)="As a result of the update the following patients have drug-allergy",CNT=CNT+1
S ^TMP($J,"TEXT",CNT)="interactions that need to be reviewed to ensure the patient's safety.",CNT=CNT+1
S SUB=0 F S SUB=$O(^TMP($J,"ERR",SUB)) Q:'+SUB D
.S ^TMP($J,"TEXT",CNT)="",CNT=CNT+1
.S ^TMP($J,"TEXT",CNT)=$$GET1^DIQ(2,SUB_",",.01),CNT=CNT+1
.S ERR=0 F S ERR=$O(^TMP($J,"ERR",SUB,ERR)) Q:'+ERR S ^TMP($J,"TEXT",CNT)=" "_^TMP($J,"ERR",SUB,ERR),CNT=CNT+1
S XMTEXT="^TMP($J,""TEXT"",",XMSUB="Potential order checks from allergy update"
D ^XMD
K ^TMP($J,"TEXT")
Q
;
TOP10 ;Check top 10 reactions after push of file 120.83
;IHS/MSC/MGH added check for inactive in the screen patch 1005
N SUB,REAC,REACNO,ARRAY,SUBNM,REACNM,GMRATXT,XMSUB,XMTEXT,XMDUZ,XMY,DIFROM,CNT
I '$L($T(SCREEN^XTID)) Q ;No screening code so quit
S SUB=0 F S SUB=$O(^GMRD(120.84,SUB)) Q:'+SUB I $D(^GMRD(120.84,SUB,1)) D
.S REAC=0 F S REAC=$O(^GMRD(120.84,SUB,1,REAC)) Q:'+REAC D
..S REACNO=$P(^GMRD(120.84,SUB,1,REAC,0),U) Q:'+REACNO
..;IHS/MSC/MGH checks added
..I $$SCREEN^XTID(120.83,.01,REACNO_",")!($$CHECKS^GMRAPER0(REACNO)) D
...S SUBNM=$P(^GMRD(120.84,SUB,0),U),REACNM=$P(^GMRD(120.83,REACNO,0),U)
...S ARRAY(SUBNM,REACNM)=""
I $D(ARRAY) D
.S XMDUZ="Data Standardization update of file 120.83",XMY("G.GMRA REQUEST NEW REACTANT")=""
.S GMRATXT(1)="The signs/symptoms file has been automatically updated. You're receiving"
.S GMRATXT(2)="this message because one or more signs/symptoms was inactivated during this"
.S GMRATXT(3)="update and the term(s) appear in your top ten list and must be replaced."
.S GMRATXT(4)="Below you will find the name of the site parameter and the terms that are now"
.S GMRATXT(5)="inactive for that entry. Use the Enter/Edit Site Parameters [GMRA SITE FILE]"
.S GMRATXT(6)="option to find and replace these terms."
.S GMRATXT(7)=""
.S CNT=7
.S SUB="" F S SUB=$O(ARRAY(SUB)) Q:SUB="" S CNT=CNT+1,GMRATXT(CNT)="Site parameter: "_SUB D S CNT=CNT+1,GMRATXT(CNT)=""
..S REAC="" F S REAC=$O(ARRAY(SUB,REAC)) Q:REAC="" S CNT=CNT+1,GMRATXT(CNT)="Term: "_REAC
.S XMTEXT="GMRATXT(",XMSUB="Signs/symptoms require updating"
.D ^XMD
Q
;
QREACT ;Queue name update, called from "AC" xref in file 120.82. Entire section added in patch 23
N OTERM,NTERM,ZTRTN,ZTDTH,ZTIO,ZTDESC
Q:X1(1)=""!(X2(1)="") ;Entry is new or has been deleted, no updating required
Q:X1(1)=X2(1) ;Entry has been updated to same value, no updating required
S OTERM=X1(1),NTERM=X2(1)
S ZTRTN="REACT^GMRAUTL2",ZTIO="GMRA UPDATE RESOURCE",ZTDTH=$H,ZTDESC="UPDATE REACTANT FIELD IN 120.8",ZTSAVE("*")="" D ^%ZTLOAD
Q
;
REACT ;Update REACTANT field with name from 120.82. Section added with patch 23
N IEN,FDA,EM,DFN
S IEN=0 F S IEN=$O(^GMR(120.8,"C",OTERM,IEN)) Q:'+IEN D
.S DFN=$P(^GMR(120.8,IEN,0),U)
.Q:$$DECEASED^GMRAFX(DFN) ;Don't update if patient is deceased
.Q:+$G(^GMR(120.8,IEN,"ER")) ;Don't update if entered in error
.L +^GMR(120.8,IEN)
.S FDA(120.8,IEN_",",.02)=NTERM
.D FILE^DIE("","FDA","EM")
.L -^GMR(120.8,IEN)
Q
;
QTYPE ;Queue allergy type updates, section added in 36
N ENTRY
S ENTRY=DA_";GMRD(120.82,"_"^"_$P(^GMRD(120.82,DA,0),"^")
Q:X1(1)=""!(X2(1)="")
Q:X1(1)=X2(1)
S ZTRTN="TYPE^GMRAUTL2",ZTIO="",ZTDTH=$H,ZTDESC="Allergy type updates",ZTSAVE("*")="" D ^%ZTLOAD
Q
;
TYPE ;Find related entries in 120.8 and update, section added in 36
N ALLERGY,POINTER,DFN,SUB
S ALLERGY=$P(ENTRY,"^",2) Q:ALLERGY=""
S POINTER=$P(ENTRY,"^") Q:POINTER=""
S SUB=0 F S SUB=$O(^GMR(120.8,"C",ALLERGY,SUB)) Q:'+SUB D
.Q:$P(^GMR(120.8,SUB,0),"^",3)'=POINTER ;Same text name but not the same entry
.S DFN=$P(^GMR(120.8,SUB,0),U)
.Q:$$DECEASED^GMRAFX(DFN) ;Don't update if patient is deceased
.Q:$G(^GMR(120.8,SUB,"ER"))>0 ;Entered in error
.S DR="3.1///"_X2(1),DIE=120.8,DA=SUB D ^DIE ;Update allergy type
Q
GMRAUTL2 ;SLC/DAN New style index utilities, update utility for 120.8 ;21-Jun-2012 08:36;DU
+1 ;;4.0;Adverse Reaction Tracking;**23,36,1005,1006**;Mar 29, 1996;Build 29
+2 ;
+3 NEW GMRAI,GMRAC,ENTRY,UPDATED
+4 ;Entry unchanged
IF $GET(X1(1))=$GET(X2(1))
QUIT
+5 SET ENTRY=DA(1)_";GMRD(120.82,"_"^"_$PIECE(^GMRD(120.82,DA(1),0),"^")
+6 ;Edited existing entry
IF $GET(X1(1))>0
IF $GET(X2(1))>0
IF $GET(GMRAT)="ING"
SET GMRAI("D",X1(1))=""
SET GMRAI("A",X2(1))=""
IF $GET(GMRAT)="CLASS"
SET GMRAC("D",X1(1))=""
SET GMRAC("A",X2(1))=""
+7 ;Entry deleted
IF $GET(X1(1))>0
IF $GET(X2(1))=""
IF $GET(GMRAT)="ING"
SET GMRAI("D",X1(1))=""
IF $GET(GMRAT)="CLASS"
SET GMRAC("D",X1(1))=""
+8 ;New entry
IF $GET(X1(1))=""
IF $GET(X2(1))>0
IF $GET(GMRAT)="ING"
SET GMRAI("A",X2(1))=""
IF $GET(GMRAT)="CLASS"
SET GMRAC("A",X2(1))=""
+9 ;Queue updating of existing entries and order checking
DO QUP
+10 QUIT
+11 ;
QUP ;Queue the update
+1 SET ZTRTN="UPDATE^GMRAUTL2(ENTRY,.GMRAI,.GMRAC)"
SET ZTIO="GMRA UPDATE RESOURCE"
SET ZTDTH=$HOROLOG
SET ZTDESC="Update existing allergies"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
QUIT
+2 ;
UPDATE(ENTRY,ING,CLASS) ;Update existing entries in 120.8 with new information.
+1 ;Entry is IEN;File reference^Text of file entry - 6;GMRD(120.82,^STRAWBERRIES
+2 ;ING - Array of ingredients - "A",IEN for those to be added and "D",IEN for those to be deleted
+3 ;CLASS - Array of drug classes - "A",IEN for those to be added and "D",IEN for those to be deleted
+4 ;
+5 NEW ALLERGY,POINTER,ACTION,SUB,SUBI,SUBC,DFN,GMRAS,GMRACOM
+6 SET ALLERGY=$PIECE(ENTRY,"^",2)
IF ALLERGY=""
QUIT
+7 SET POINTER=$PIECE(ENTRY,"^")
IF POINTER=""
QUIT
+8 SET SUB=0
FOR
SET SUB=$ORDER(^GMR(120.8,"C",ALLERGY,SUB))
IF '+SUB
QUIT
Begin DoDot:1
+9 SET DFN=$PIECE(^GMR(120.8,SUB,0),U)
+10 ;Don't update if patient is deceased
IF $$DECEASED^GMRAFX(DFN)
QUIT
+11 ;Same text name but not the same entry
IF $PIECE(^GMR(120.8,SUB,0),"^",3)'=POINTER
QUIT
+12 ;Entered in error
IF $GET(^GMR(120.8,SUB,"ER"))>0
QUIT
+13 SET GMRACOM=0
+14 FOR ACTION="A","D"
Begin DoDot:2
+15 SET SUBI=0
FOR
SET SUBI=$ORDER(ING(ACTION,SUBI))
IF '+SUBI
QUIT
Begin DoDot:3
+16 IF ACTION="A"
DO ADD("I",SUB,SUBI,.GMRAS)
IF $GET(GMRAS)
SET ING(ACTION,SUBI)=1
SET GMRACOM=1
SET UPDATED(DFN)=""
+17 IF ACTION="D"
DO DEL("I",SUB,SUBI,.GMRAS)
IF $GET(GMRAS)
SET ING(ACTION,SUBI)=1
SET GMRACOM=1
End DoDot:3
+18 SET SUBC=0
FOR
SET SUBC=$ORDER(CLASS(ACTION,SUBC))
IF '+SUBC
QUIT
Begin DoDot:3
+19 IF ACTION="A"
DO ADD("C",SUB,SUBC,.GMRAS)
IF $GET(GMRAS)
SET CLASS(ACTION,SUBC)=1
SET UPDATED(DFN)=""
SET GMRACOM=1
+20 IF ACTION="D"
DO DEL("C",SUB,SUBC,.GMRAS)
IF $GET(GMRAS)
SET GMRACOM=1
SET CLASS(ACTION,SUBC)=1
End DoDot:3
End DoDot:2
+21 IF $GET(GMRACOM)
DO ADDCOM
End DoDot:1
+22 ;New order checks now?
IF $DATA(UPDATED)
DO CHKORD
+23 QUIT
+24 ;
ADD(TYPE,ALENT,SUBENT,GMRAS) ;Adds entry to appropriate multiple
+1 NEW FILE,FDA,EM
+2 SET GMRAS=1
+3 ;Entry already exists
IF $DATA(^GMR(120.8,ALENT,$SELECT(TYPE="I":2,1:3),"B",SUBENT))
SET GMRAS=0
QUIT
+4 LOCK +^GMR(120.8,ALENT)
+5 SET FILE=$SELECT(TYPE="I":120.802,1:120.803)
+6 SET FDA(FILE,"+1,"_ALENT_",",.01)=SUBENT
+7 DO UPDATE^DIE("","FDA",,"EM")
+8 LOCK -^GMR(120.8,ALENT)
+9 QUIT
+10 ;
DEL(TYPE,ALENT,SUBENT,GMRAS) ;Delete entry from multiple
+1 NEW FILE,FDA,EM,ENTRY
+2 SET GMRAS=1
+3 ;No entry to delete
IF '$DATA(^GMR(120.8,ALENT,$SELECT(TYPE="I":2,1:3),"B",SUBENT))
SET GMRAS=0
QUIT
+4 LOCK +^GMR(120.8,ALENT)
+5 SET ENTRY=$ORDER(^GMR(120.8,ALENT,$SELECT(TYPE="I":2,1:3),"B",SUBENT,0))
IF '+ENTRY
QUIT
+6 SET FILE=$SELECT(TYPE="I":120.802,1:120.803)
+7 SET FDA(FILE,ENTRY_","_ALENT_",",.01)="@"
+8 DO FILE^DIE("","FDA","EM")
+9 LOCK -^GMR(120.8,ALENT)
+10 QUIT
+11 ;
CHKORD ;Check for orders that are now in conflict with existing allergy data
+1 NEW TIME,GMRAOC,ORX,SUB,GMRAORX,GI,CNT,DFN
+2 ;Don't check if no valid user to send data to
IF '+$GET(DUZ)
QUIT
+3 KILL ^TMP("ORR",$JOB),^TMP($JOB,"ERR")
+4 SET DFN=0
FOR
SET DFN=$ORDER(UPDATED(DFN))
IF '+DFN
QUIT
Begin DoDot:1
+5 ;Retrieve active orders
DO EN^ORQ1(DFN_";DPT(")
+6 SET TIME=$ORDER(^TMP("ORR",$JOB,0))
+7 ;No orders found
IF '^TMP("ORR",$JOB,TIME,"TOT")
QUIT
+8 SET SUB=0
FOR
SET SUB=$ORDER(^TMP("ORR",$JOB,TIME,SUB))
IF '+SUB
QUIT
Begin DoDot:2
+9 ;Get "order" information in order checking format
DO BLD^ORCHECK(+^TMP("ORR",$JOB,TIME,SUB))
End DoDot:2
+10 MERGE GMRAORX=ORX
KILL ORX,GMRAOC
+11 DO EN^ORKCHK(.GMRAOC,DFN,.GMRAORX,"ACCEPT")
+12 SET GI=0
SET CNT=0
FOR
SET GI=$ORDER(GMRAOC(GI))
IF '+GI
QUIT
Begin DoDot:2
+13 ;Quit if not allergy related
IF $PIECE(GMRAOC(GI),U,2)'=3
QUIT
+14 ;Quit if existing allergy order check, can't be for this new information
IF $DATA(^OR(100,$PIECE(GMRAOC(GI),U),9,"B",3))
QUIT
+15 SET CNT=CNT+1
SET ^TMP($JOB,"ERR",DFN,CNT)=$PIECE($$STATUS^ORQOR2($PIECE(GMRAOC(GI),U)),U,2)_" order for "_$PIECE($$OI^ORX8($PIECE(GMRAOC(GI),U)),U,2)_",order #"_$PIECE(GMRAOC(GI),U)
End DoDot:2
+16 ;Remove previous list of orders
KILL GMRAORX
End DoDot:1
+17 DO MAIL
KILL ^TMP("ORR",$JOB),^TMP($JOB,"ERR")
+18 QUIT
+19 ;
ADDCOM ;Add comment to updated allergy indicating changes
+1 QUIT
+2 NEW TYPE,ROOT,SUB2,DICR,DIEL,DL,DP,DM,DK,DIK,DC,DE,GLOB,DH,D,DQ,DR,DIC,DIE,DIA,DI,DG,DDH,DDER,DA,D0,D1
+3 FOR GLOB="ING(""A"")","ING(""D"")","CLASS(""A"")","CLASS(""D"")"
IF $DATA(@GLOB)
Begin DoDot:1
+4 ;Determines if we're adding or deleting ingredients or classes
SET TYPE=$SELECT(GLOB="ING(""A"")":1,GLOB="ING(""D"")":2,GLOB="CLASS(""A"")":3,1:4)
+5 SET COM="The following "_$SELECT(TYPE=1!(TYPE=2):"ingredients",1:"drug classes")_" were "_$SELECT(TYPE=2!(TYPE=4):"deleted",1:"added")_": "
+6 SET ROOT=$SELECT(TYPE=1:"ING(""A"")",TYPE=2:"ING(""D"")",TYPE=3:"CLASS(""A"")",1:"CLASS(""D"")")
+7 SET SUB2=0
FOR
SET SUB2=$ORDER(@ROOT@(SUB2))
IF '+SUB2
QUIT
IF @ROOT@(SUB2)
SET COM=COM_$SELECT($PIECE(COM,": ",2)'="":", ",1:"")_$SELECT(TYPE=1!(TYPE=2):$$GET1^DIQ(50.416,SUB2_",",.01),1:$$GET1^DIQ(50.605,SUB2_",",.01))
+8 IF $PIECE(COM,": ",2)'=""
LOCK +^GMR(120.8,SUB)
DO ADCOM^GMRAFX(SUB,"O",COM)
LOCK -^GMR(120.8,SUB)
End DoDot:1
+9 QUIT
+10 ;
MAIL ;Send message containing potential order checks to user.
+1 NEW XMSUB,XMTEXT,XMDUZ,XMY,XMZ,CNT,SUB,ERR,TYPE,NUM
+2 ;Nothing to report
IF '$DATA(^TMP($JOB,"ERR"))
QUIT
+3 KILL ^TMP($JOB,"TEXT")
+4 SET XMDUZ="Allergy auto-update program"
+5 ;Send to user who initiated change or postmaster
SET XMY($GET(DUZ,.5))=""
+6 ;Include mail group to be sure someone gets this message
SET XMY("G.GMRA REQUEST NEW REACTANT")=""
+7 SET CNT=1
+8 SET ^TMP($JOB,"TEXT",CNT)="The "_$PIECE(ENTRY,U,2)_" reactant was updated."
SET CNT=CNT+1
+9 SET ^TMP($JOB,"TEXT",CNT)="The following drug classes and/or drug ingredients were added:"
SET CNT=CNT+1
SET ^TMP($JOB,"TEXT",CNT)=""
SET CNT=CNT+1
+10 FOR TYPE="GMRAI","GMRAC"
Begin DoDot:1
+11 IF $DATA(@(TYPE))
Begin DoDot:2
+12 SET ^TMP($JOB,"TEXT",CNT)=$SELECT(TYPE="GMRAI":"Ingredients",1:"Classes")_": "
SET CNT=CNT+1
+13 SET NUM=0
FOR
SET NUM=$ORDER(@TYPE@("A",NUM))
IF '+NUM
QUIT
SET ^TMP($JOB,"TEXT",CNT)=$GET(^TMP($JOB,"TEXT",CNT))_$SELECT($LENGTH($GET(^TMP($JOB,"TEXT",CNT))):",",1:"")_$$GET1^DIQ($SELECT(TYPE="GMRAI":50.416,1:50.605),NUM_",",.01)
+14 SET CNT=CNT+1
SET ^TMP($JOB,"TEXT",CNT)=""
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+15 SET ^TMP($JOB,"TEXT",CNT)="As a result of the update the following patients have drug-allergy"
SET CNT=CNT+1
+16 SET ^TMP($JOB,"TEXT",CNT)="interactions that need to be reviewed to ensure the patient's safety."
SET CNT=CNT+1
+17 SET SUB=0
FOR
SET SUB=$ORDER(^TMP($JOB,"ERR",SUB))
IF '+SUB
QUIT
Begin DoDot:1
+18 SET ^TMP($JOB,"TEXT",CNT)=""
SET CNT=CNT+1
+19 SET ^TMP($JOB,"TEXT",CNT)=$$GET1^DIQ(2,SUB_",",.01)
SET CNT=CNT+1
+20 SET ERR=0
FOR
SET ERR=$ORDER(^TMP($JOB,"ERR",SUB,ERR))
IF '+ERR
QUIT
SET ^TMP($JOB,"TEXT",CNT)=" "_^TMP($JOB,"ERR",SUB,ERR)
SET CNT=CNT+1
End DoDot:1
+21 SET XMTEXT="^TMP($J,""TEXT"","
SET XMSUB="Potential order checks from allergy update"
+22 DO ^XMD
+23 KILL ^TMP($JOB,"TEXT")
+24 QUIT
+25 ;
TOP10 ;Check top 10 reactions after push of file 120.83
+1 ;IHS/MSC/MGH added check for inactive in the screen patch 1005
+2 NEW SUB,REAC,REACNO,ARRAY,SUBNM,REACNM,GMRATXT,XMSUB,XMTEXT,XMDUZ,XMY,DIFROM,CNT
+3 ;No screening code so quit
IF '$LENGTH($TEXT(SCREEN^XTID))
QUIT
+4 SET SUB=0
FOR
SET SUB=$ORDER(^GMRD(120.84,SUB))
IF '+SUB
QUIT
IF $DATA(^GMRD(120.84,SUB,1))
Begin DoDot:1
+5 SET REAC=0
FOR
SET REAC=$ORDER(^GMRD(120.84,SUB,1,REAC))
IF '+REAC
QUIT
Begin DoDot:2
+6 SET REACNO=$PIECE(^GMRD(120.84,SUB,1,REAC,0),U)
IF '+REACNO
QUIT
+7 ;IHS/MSC/MGH checks added
+8 IF $$SCREEN^XTID(120.83,.01,REACNO_",")!($$CHECKS^GMRAPER0(REACNO))
Begin DoDot:3
+9 SET SUBNM=$PIECE(^GMRD(120.84,SUB,0),U)
SET REACNM=$PIECE(^GMRD(120.83,REACNO,0),U)
+10 SET ARRAY(SUBNM,REACNM)=""
End DoDot:3
End DoDot:2
End DoDot:1
+11 IF $DATA(ARRAY)
Begin DoDot:1
+12 SET XMDUZ="Data Standardization update of file 120.83"
SET XMY("G.GMRA REQUEST NEW REACTANT")=""
+13 SET GMRATXT(1)="The signs/symptoms file has been automatically updated. You're receiving"
+14 SET GMRATXT(2)="this message because one or more signs/symptoms was inactivated during this"
+15 SET GMRATXT(3)="update and the term(s) appear in your top ten list and must be replaced."
+16 SET GMRATXT(4)="Below you will find the name of the site parameter and the terms that are now"
+17 SET GMRATXT(5)="inactive for that entry. Use the Enter/Edit Site Parameters [GMRA SITE FILE]"
+18 SET GMRATXT(6)="option to find and replace these terms."
+19 SET GMRATXT(7)=""
+20 SET CNT=7
+21 SET SUB=""
FOR
SET SUB=$ORDER(ARRAY(SUB))
IF SUB=""
QUIT
SET CNT=CNT+1
SET GMRATXT(CNT)="Site parameter: "_SUB
Begin DoDot:2
+22 SET REAC=""
FOR
SET REAC=$ORDER(ARRAY(SUB,REAC))
IF REAC=""
QUIT
SET CNT=CNT+1
SET GMRATXT(CNT)="Term: "_REAC
End DoDot:2
SET CNT=CNT+1
SET GMRATXT(CNT)=""
+23 SET XMTEXT="GMRATXT("
SET XMSUB="Signs/symptoms require updating"
+24 DO ^XMD
End DoDot:1
+25 QUIT
+26 ;
QREACT ;Queue name update, called from "AC" xref in file 120.82. Entire section added in patch 23
+1 NEW OTERM,NTERM,ZTRTN,ZTDTH,ZTIO,ZTDESC
+2 ;Entry is new or has been deleted, no updating required
IF X1(1)=""!(X2(1)="")
QUIT
+3 ;Entry has been updated to same value, no updating required
IF X1(1)=X2(1)
QUIT
+4 SET OTERM=X1(1)
SET NTERM=X2(1)
+5 SET ZTRTN="REACT^GMRAUTL2"
SET ZTIO="GMRA UPDATE RESOURCE"
SET ZTDTH=$HOROLOG
SET ZTDESC="UPDATE REACTANT FIELD IN 120.8"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
+6 QUIT
+7 ;
REACT ;Update REACTANT field with name from 120.82. Section added with patch 23
+1 NEW IEN,FDA,EM,DFN
+2 SET IEN=0
FOR
SET IEN=$ORDER(^GMR(120.8,"C",OTERM,IEN))
IF '+IEN
QUIT
Begin DoDot:1
+3 SET DFN=$PIECE(^GMR(120.8,IEN,0),U)
+4 ;Don't update if patient is deceased
IF $$DECEASED^GMRAFX(DFN)
QUIT
+5 ;Don't update if entered in error
IF +$GET(^GMR(120.8,IEN,"ER"))
QUIT
+6 LOCK +^GMR(120.8,IEN)
+7 SET FDA(120.8,IEN_",",.02)=NTERM
+8 DO FILE^DIE("","FDA","EM")
+9 LOCK -^GMR(120.8,IEN)
End DoDot:1
+10 QUIT
+11 ;
QTYPE ;Queue allergy type updates, section added in 36
+1 NEW ENTRY
+2 SET ENTRY=DA_";GMRD(120.82,"_"^"_$PIECE(^GMRD(120.82,DA,0),"^")
+3 IF X1(1)=""!(X2(1)="")
QUIT
+4 IF X1(1)=X2(1)
QUIT
+5 SET ZTRTN="TYPE^GMRAUTL2"
SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTDESC="Allergy type updates"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
+6 QUIT
+7 ;
TYPE ;Find related entries in 120.8 and update, section added in 36
+1 NEW ALLERGY,POINTER,DFN,SUB
+2 SET ALLERGY=$PIECE(ENTRY,"^",2)
IF ALLERGY=""
QUIT
+3 SET POINTER=$PIECE(ENTRY,"^")
IF POINTER=""
QUIT
+4 SET SUB=0
FOR
SET SUB=$ORDER(^GMR(120.8,"C",ALLERGY,SUB))
IF '+SUB
QUIT
Begin DoDot:1
+5 ;Same text name but not the same entry
IF $PIECE(^GMR(120.8,SUB,0),"^",3)'=POINTER
QUIT
+6 SET DFN=$PIECE(^GMR(120.8,SUB,0),U)
+7 ;Don't update if patient is deceased
IF $$DECEASED^GMRAFX(DFN)
QUIT
+8 ;Entered in error
IF $GET(^GMR(120.8,SUB,"ER"))>0
QUIT
+9 ;Update allergy type
SET DR="3.1///"_X2(1)
SET DIE=120.8
SET DA=SUB
DO ^DIE
End DoDot:1
+10 QUIT
