- GMRAUTL2 ;SLC/DAN - New style index utilities, update utility for 120.8 ;11/20/12 08:09
- ;;4.0;Adverse Reaction Tracking;**23,36,41,45,47**;Mar 29, 1996;Build 21
- ;DBIA Section
- ;%ZTLOAD - 10063
- ;DIE - 10018
- ;FILE^DIE - 2053
- ;UPDATE^DIE - 2053
- ;DIQ - 2056
- ;ORCHECK - 4859
- ;ORKCHK - 4135
- ;ORQOR2 - 3458
- ;ORX8 - 2467
- ;PSN50P41 - 4531
- ;PSN50P65 - 4543
- ;XLFDT - 10103
- ;XTID - 4631
- ;
- N GMRAI,GMRAC,ENTRY
- 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
- N ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTSAVE
- 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,UPDATED
- 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):20 I '$T Q
- 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):20 I '$T Q
- 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
- .N ORDODSG S ORDODSG=0
- .D EN^ORKCHK(.GMRAOC,DFN,.GMRAORX,"ACCEPT",,.ORDODSG)
- .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
- ..Q:$$ANYARTOC^GMRAUTL2($P(GMRAOC(GI),U)) ;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
- ;
- ANYARTOC(GMRAIFN) ;check order to see if there are any allergy order checks
- N GMRARET,GMRAI
- S GMRARET=0
- K ^TMP($J,"GMRAOC")
- D OCAPI^ORCHECK(+GMRAIFN,"GMRAOC")
- S GMRAI=0 F S GMRAI=$O(^TMP($J,"GMRAOC",GMRAI)) Q:'GMRAI I $G(^TMP($J,"GMRAOC",GMRAI,"OC NUMBER"))=3 S GMRARET=1
- K ^TMP($J,"GMRAOC")
- Q GMRARET
- ADDCOM ;Add comment to updated allergy indicating changes
- D ADDCOM^GMRAUTL3 ;41 Moved section due to space considerations
- 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"),^TMP($J,"GMRAINFO") ;41 Clear out storage area
- 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:"") D ;41 added call for data in structure below
- ...I TYPE="GMRAI" D ZERO^PSN50P41(NUM,,$$DT^XLFDT,"GMRAINFO") ;41 ingredient call
- ...I TYPE="GMRAC" D C^PSN50P65(NUM,,"GMRAINFO") ;41 drug class call
- ...S ^TMP($J,"TEXT",CNT)=^TMP($J,"TEXT",CNT)_$G(^TMP($J,"GMRAINFO",NUM,.01)) ;41 add data
- ..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
- 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
- ..I $$SCREEN^XTID(120.83,.01,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):20 I '$T Q
- .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,ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTSAVE
- 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,DR,DIE,DA
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAUTL2 10353 printed Apr 23, 2025@17:55:07 Page 2
- GMRAUTL2 ;SLC/DAN - New style index utilities, update utility for 120.8 ;11/20/12 08:09
- +1 ;;4.0;Adverse Reaction Tracking;**23,36,41,45,47**;Mar 29, 1996;Build 21
- +2 ;DBIA Section
- +3 ;%ZTLOAD - 10063
- +4 ;DIE - 10018
- +5 ;FILE^DIE - 2053
- +6 ;UPDATE^DIE - 2053
- +7 ;DIQ - 2056
- +8 ;ORCHECK - 4859
- +9 ;ORKCHK - 4135
- +10 ;ORQOR2 - 3458
- +11 ;ORX8 - 2467
- +12 ;PSN50P41 - 4531
- +13 ;PSN50P65 - 4543
- +14 ;XLFDT - 10103
- +15 ;XTID - 4631
- +16 ;
- +17 NEW GMRAI,GMRAC,ENTRY
- +18 ;Entry unchanged
- if $GET(X1(1))=$GET(X2(1))
- QUIT
- +19 SET ENTRY=DA(1)_";GMRD(120.82,"_"^"_$PIECE(^GMRD(120.82,DA(1),0),"^")
- +20 ;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))=""
- +21 ;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))=""
- +22 ;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))=""
- +23 ;Queue updating of existing entries and order checking
- DO QUP
- +24 QUIT
- +25 ;
- QUP ;Queue the update
- +1 NEW ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTSAVE
- +2 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
- +3 ;
- 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,UPDATED
- +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):20
- IF '$TEST
- QUIT
- +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):20
- IF '$TEST
- QUIT
- +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 NEW ORDODSG
- SET ORDODSG=0
- +12 DO EN^ORKCHK(.GMRAOC,DFN,.GMRAORX,"ACCEPT",,.ORDODSG)
- +13 SET GI=0
- SET CNT=0
- FOR
- SET GI=$ORDER(GMRAOC(GI))
- if '+GI
- QUIT
- Begin DoDot:2
- +14 ;Quit if not allergy related
- if $PIECE(GMRAOC(GI),U,2)'=3
- QUIT
- +15 ;Q:$D(^OR(100,$P(GMRAOC(GI),U),9,"B",3)) ;Quit if existing allergy order check, can't be for this new information
- +16 ;Quit if existing allergy order check, can't be for this new information
- if $$ANYARTOC^GMRAUTL2($PIECE(GMRAOC(GI),U))
- QUIT
- +17 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
- +18 ;Remove previous list of orders
- KILL GMRAORX
- End DoDot:1
- +19 DO MAIL
- KILL ^TMP("ORR",$JOB),^TMP($JOB,"ERR")
- +20 QUIT
- +21 ;
- ANYARTOC(GMRAIFN) ;check order to see if there are any allergy order checks
- +1 NEW GMRARET,GMRAI
- +2 SET GMRARET=0
- +3 KILL ^TMP($JOB,"GMRAOC")
- +4 DO OCAPI^ORCHECK(+GMRAIFN,"GMRAOC")
- +5 SET GMRAI=0
- FOR
- SET GMRAI=$ORDER(^TMP($JOB,"GMRAOC",GMRAI))
- if 'GMRAI
- QUIT
- IF $GET(^TMP($JOB,"GMRAOC",GMRAI,"OC NUMBER"))=3
- SET GMRARET=1
- +6 KILL ^TMP($JOB,"GMRAOC")
- +7 QUIT GMRARET
- ADDCOM ;Add comment to updated allergy indicating changes
- +1 ;41 Moved section due to space considerations
- DO ADDCOM^GMRAUTL3
- +2 QUIT
- +3 ;
- 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 ;41 Clear out storage area
- KILL ^TMP($JOB,"TEXT"),^TMP($JOB,"GMRAINFO")
- +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 ;41 added call for data in structure below
- 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:"")
- Begin DoDot:3
- +14 ;41 ingredient call
- IF TYPE="GMRAI"
- DO ZERO^PSN50P41(NUM,,$$DT^XLFDT,"GMRAINFO")
- +15 ;41 drug class call
- IF TYPE="GMRAC"
- DO C^PSN50P65(NUM,,"GMRAINFO")
- +16 ;41 add data
- SET ^TMP($JOB,"TEXT",CNT)=^TMP($JOB,"TEXT",CNT)_$GET(^TMP($JOB,"GMRAINFO",NUM,.01))
- End DoDot:3
- +17 SET CNT=CNT+1
- SET ^TMP($JOB,"TEXT",CNT)=""
- SET CNT=CNT+1
- End DoDot:2
- End DoDot:1
- +18 SET ^TMP($JOB,"TEXT",CNT)="As a result of the update the following patients have drug-allergy"
- SET CNT=CNT+1
- +19 SET ^TMP($JOB,"TEXT",CNT)="interactions that need to be reviewed to ensure the patient's safety."
- SET CNT=CNT+1
- +20 SET SUB=0
- FOR
- SET SUB=$ORDER(^TMP($JOB,"ERR",SUB))
- if '+SUB
- QUIT
- Begin DoDot:1
- +21 SET ^TMP($JOB,"TEXT",CNT)=""
- SET CNT=CNT+1
- +22 SET ^TMP($JOB,"TEXT",CNT)=$$GET1^DIQ(2,SUB_",",.01)
- SET CNT=CNT+1
- +23 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
- +24 SET XMTEXT="^TMP($J,""TEXT"","
- SET XMSUB="Potential order checks from allergy update"
- +25 DO ^XMD
- +26 KILL ^TMP($JOB,"TEXT")
- +27 QUIT
- +28 ;
- TOP10 ;Check top 10 reactions after push of file 120.83
- +1 NEW SUB,REAC,REACNO,ARRAY,SUBNM,REACNM,GMRATXT,XMSUB,XMTEXT,XMDUZ,XMY,DIFROM,CNT
- +2 ;No screening code so quit
- IF '$LENGTH($TEXT(SCREEN^XTID))
- QUIT
- +3 SET SUB=0
- FOR
- SET SUB=$ORDER(^GMRD(120.84,SUB))
- if '+SUB
- QUIT
- IF $DATA(^GMRD(120.84,SUB,1))
- Begin DoDot:1
- +4 SET REAC=0
- FOR
- SET REAC=$ORDER(^GMRD(120.84,SUB,1,REAC))
- if '+REAC
- QUIT
- Begin DoDot:2
- +5 SET REACNO=$PIECE(^GMRD(120.84,SUB,1,REAC,0),U)
- if '+REACNO
- QUIT
- +6 IF $$SCREEN^XTID(120.83,.01,REACNO_",")
- Begin DoDot:3
- +7 SET SUBNM=$PIECE(^GMRD(120.84,SUB,0),U)
- SET REACNM=$PIECE(^GMRD(120.83,REACNO,0),U)
- +8 SET ARRAY(SUBNM,REACNM)=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +9 IF $DATA(ARRAY)
- Begin DoDot:1
- +10 SET XMDUZ="Data Standardization update of file 120.83"
- SET XMY("G.GMRA REQUEST NEW REACTANT")=""
- +11 SET GMRATXT(1)="The signs/symptoms file has been automatically updated. You're receiving"
- +12 SET GMRATXT(2)="this message because one or more signs/symptoms was inactivated during this"
- +13 SET GMRATXT(3)="update and the term(s) appear in your top ten list and must be replaced."
- +14 SET GMRATXT(4)="Below you will find the name of the site parameter and the terms that are now"
- +15 SET GMRATXT(5)="inactive for that entry. Use the Enter/Edit Site Parameters [GMRA SITE FILE]"
- +16 SET GMRATXT(6)="option to find and replace these terms."
- +17 SET GMRATXT(7)=""
- +18 SET CNT=7
- +19 SET SUB=""
- FOR
- SET SUB=$ORDER(ARRAY(SUB))
- if SUB=""
- QUIT
- SET CNT=CNT+1
- SET GMRATXT(CNT)="Site parameter: "_SUB
- Begin DoDot:2
- +20 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)=""
- +21 SET XMTEXT="GMRATXT("
- SET XMSUB="Signs/symptoms require updating"
- +22 DO ^XMD
- End DoDot:1
- +23 QUIT
- +24 ;
- 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):20
- IF '$TEST
- QUIT
- +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,ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTSAVE
- +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,DR,DIE,DA
- +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
