BPXRMAL1 ;IHS/MSC/MGH - Handle Allergy findings for drugs ;30-Mar-2018 14:29;DU
;;2.0;CLINICAL REMINDERS;**1001,1002,1009**;Feb 04, 2005;Build 17
;--------------------------------------------------------------
;Patch 1009 added Statin drugs
;ROUTINE TO TEST ALLERGY STATUS
;ENTRY POINT REM JUST NEEDS THE PSODFN.NOT NECESSARILY THE TERM WILL FIND ALL
;TERMS THAT HAVE DRUGS IN THEM EITHER DRUG OR VA GENERIC
Q
;
ASAREM(PSODFN,TEST,DATE,VALUE,TEXT) ; EP ASPIRIN COMPUTED ALLERGY CHECK RETURN TEST=1 IF ALLERGY
S TERM="IHS-ASPIRIN"
D REM(PSODFN,.TEST,.DATE,.VALUE,.TEXT)
Q
;
STATREM(PSODFN,TEST,DATE,VALUE,TEXT) ;EP Statin computed allergy check added patch 1009
S TERM="IHS-STATIN DRUGS"
D REM(PSODFN,.TEST,.DATE,.VALUE,.TEXT)
Q
;
AAREM(PSODFN,TEST,DATE,VALUE,TEXT) ; EP ACE/ARB COMPUTED ALLERGY CHECK RETURN TEST=1 IF ALLERGY
N VALUE,TEST1,TEXT1,TEST2,TEXT2
S VALUE="",DATE=DT,CHECK=""
S I="CV800"
S CHECK=$$FIND1^DIC(50.605,"","MX",I)_"C"
I CHECK="" S TEST=0,TEXT="VA DRUG CLASSES FOR 'CV800' NOT DEFINED!!" Q
D ALLER(PSODFN,CHECK,.TEST1,.TEXT1)
S I="CV805"
S CHECK=$$FIND1^DIC(50.605,"","MX",I)_"C"
I CHECK="" S TEST=0,TEXT="VA DRUG CLASSES FOR 'CV805' NOT DEFINED!!" Q
D ALLER(PSODFN,CHECK,.TEST2,.TEXT2)
I TEST1=1&(TEST2=1) S TEST=1,TEXT="ALLERGIES TO BOTH"
E S TEST=0,TEXT="ALLERGIES TO BOTH CLASSES NOT FOUND"
Q
;
REM(PSODFN,TEST,DATE,VALUE,TEXT) ; EP YOU GIVE THE PSODFN AND THE TERM DEFINDED BELOW
;MAIN ENTRY POINT ABOVE GIVEN PSODFN AND TERM
;TERM IS THE NAME OF THE REMINDER TERM TO QUERY
;IF I DON'T HAVE A TERM I'LL QUERY THE REMINDER TERM LOOKING FOR A DRUG OR VA DRUG TERM
;--------------------------------------------------------------------
S DATE=DT,VALUE=""
N RESULT,TERMLONG,TERMS,I
I $G(TERM)']"" D ;ADD THIS BELOW FOR CASE WHEN NO TERM DEFINED IHS/OKCAO/POC 11/7/2006
.D LIST^DIC(811.902,","_PXRMITEM_",",.01,"I",,,,,,,"TERMLONG")
.M TERMS=TERMLONG("DILIST",1)
.S I="" F S I=$O(TERMS(I)) Q:I="" I $P(TERMS(I),";",2)'="PXRMD(811.5," K TERMS(I) ;JUST THE TERMS
.I '$D(TERMS) S TEST=0,TEXT="THERE ARE NO VALID TERM FINDINGS (DRUG OR VA DRUG) IN THE REMINDER TAXONMY "_$$GET1^DIQ(811.9,PXRMITEM_",",.01) Q ;NO VALID TERM DRUG OR VA DRUG FINDINGS IN THE REMINDER TERM
.S I="" F S I=$O(TERMS(I)) Q:I="" Q:$G(TEST) S TERM="`"_$P(TERMS(I),";") D ;QUIT IS TEST=1 FOUND ALLERGY TO SOMETHING DON'T OVERWRITE IT
..D TERM(TERM,.RETURN)
..I '$G(RETURN) S TEST=0,TEXT="THERE ARE NO VALID FINDINGS IN THE REMINDER TAXONMY "_$$GET1^DIQ(811.9,PXRMITEM_",",.01) Q ;NO VALID FINDINGS IN THE REMINDER TERM
..D ALLER(PSODFN,RETURN,.TEST,.TEXT)
;I $G(TERM)']"" S TEST=0,TEXT="NEED TO DEFINE THE TERM. CALL PROGRAMMER!" Q
;GIVE THE TERM ALSO <---
E D
.D TERM(TERM,.RETURN)
.I '$G(RETURN) S TEST=0,TEXT="THERE ARE NO VALID FINDINGS IN THE REMINDER TAXONMY "_TERM Q ;NO VALID FINDINGS IN THE REMINDER TERM
.D ALLER(PSODFN,RETURN,.TEST,.TEXT)
Q
;END OF CHANGES IHS/OKCAO/POC 11/7/2006
;
TERM(TERM,RETURN) ;GIVEN REMINDER TERM RETURN THE STRING TO PASS TO ALLER
;FINDINGS MUST BE FROM THE DRUG FILE!!
N TARLONG,IEN,FINDINGS,TERMIEN
K RETURN
S TERMIEN=$$FIND1^DIC(811.5,"","MX",TERM) ;REMINDER TERM
I 'TERMIEN S TEST=0,TEXT="NO REMINDER TERM "_TERM_" FOUND!!" Q
D LIST^DIC(811.52,","_TERMIEN_",",".01","I","","","","",,"","TARLONG")
M FINDINGS=TARLONG("DILIST",1) ;FINDINGS FOR THIS REMINDER
S IEN="" F S IEN=$O(FINDINGS(IEN)) Q:'IEN D
.;WE'LL ONLY LOOK AT ENTRIES POINTING TO DRUGS OR VA GENERICS NOT VA CLASSES IHS/OKCAO/POC 5/11/2006
.S RETURN=$G(RETURN)_"^"_$S(FINDINGS(IEN)["PSDRUG":+FINDINGS(IEN)_"D",FINDINGS(IEN)["PSNDF(50.6,":+FINDINGS(IEN)_"G",1:"")
S RETURN=$E($G(RETURN),2,$L($G(RETURN))) ;GET RID OF FIRST '^')
Q
;
ALLER(PSODFN,CHECK,TEST,TEXT) ; EP
;TEST =1 IF ALLERGY 0 IF NO ALLERGY TEXT IS WRITTEN TEXT
;PSODFN=DFN CHECK=IS THE ENTITY TO CHECK SEE STING TAG
;CHECK CAN BE MUTIPLES SEPARATED BY '^'
;INPUT GMRAAR LIKE THIS FOR FILE 120.82=IEN_"A", FILE 50=IEN_"D", FILE 50.6=IEN_"G", FILE 50.605=IEN_"C", FILE 50.416=IEN_"I"
;EXAMPLE CHECK="305D^276C WOULD BE IEN 305 IN FILE 50 AND IEN 276 IN 50.605
;-------------------------------------------------------------------
N REACTION
S TEST=0,TEXT=""
S REACTION=$$NKA^GMRANKA(PSODFN)
I REACTION="" S TEXT="NO ALLERGY INFORMATION FOR THIS PATIENT HAS BEEN RECORDED" Q
I REACTION=0 S TEXT="THIS PATIENT HAS BEEN RECORDED AS 'NKA'" Q
K ING,CLASS,DRUG
F I=1:1 S GMRAAR=$P(CHECK,"^",I) Q:GMRAAR="" D STING(GMRAAR,.ING,.CLASS,.DRUG)
;NOW YOU HAVE ARRAY OF ING-VA INGREDIENT IEN, CLASS- VA DRUG CLASS IENS, AND DRUG-DRUG IEN
;START LOOPING THROUGH THE GMR(120.8 GLOBAL
N IEN
S IEN=0 F S IEN=$O(^GMR(120.8,"B",PSODFN,IEN)) Q:IEN'=+IEN!TEST D
.Q:$$TEST(IEN) ;NOT VERIFIED OR IS AN ERROR OR IS INACTIVE
.N INGIEN
.S INGIEN=0 F S INGIEN=$O(^GMR(120.8,IEN,2,"B",INGIEN)) Q:INGIEN'=+INGIEN!TEST D
..I $D(ING(INGIEN)) S TEST=1,DATE=DT,TEXT="PT ALLERGIC TO DRUG INGREDIENT "_$P($G(^PS(50.416,INGIEN,0)),"^")_" IN PATIENT ALLERGY "_$P($G(^GMR(120.8,IEN,0)),"^",2)_"-"_IEN
.Q:TEST
.N CLASSIEN
.S CLASSIEN=0 F S CLASSIEN=$O(^GMR(120.8,IEN,3,"B",CLASSIEN)) Q:CLASSIEN'=+CLASSIEN!TEST D
..I $D(CLASS(CLASSIEN)) S TEST=1,DATE=DT,TEXT="PT ALLERGIC TO DRUG CLASS "_$P($G(^PS(50.605,CLASSIEN,0)),"^")_" IN PATIENT ALLERGY "_$P($G(^GMR(120.8,IEN,0)),"^",2)_"-"_IEN
.Q:TEST
.N DRUGIEN
.S DRUGIEN=$P(^GMR(120.8,IEN,0),"^",3)
.I DRUGIEN["PSDRUG(" S:$D(DRUG(+DRUGIEN)) TEST=1,DATE=DT,TEXT="PT ALLERGIC TO DRUG "_$P($G(^PSDRUG(+DRUGIEN,0)),"^")_" IN PATIENT ALLERGY "_$P($G(^GMR(120.8,IEN,0)),"^",2)_"-"_IEN
Q
;
STING(GMRAAR,GMRAING,GMRADRCL,PSODRUG) ;
;INPUT GMRAAR LIKE THIS FOR FILE 120.82=IEN_"A", FILE 50=IEN_"D", FILE 50.6=IEN_"G", FILE 50.605=IEN_"C", FILE 50.416=IEN_"I"
;GMRAING=DRUG INGREDIENTS, AND GMRADRCL=VA DRUG CLASS, AND PSODRUG=DRUG ARE RETURNED IN ARRAY
;K GMRAING,GMRADRCL ;GMRAING=DRUG INGREDIENTS GMRADRCL=CLASSES
;------------------------------------------------------------------------
N Y
I GMRAAR["I" S GMRAING(+GMRAAR)=""
;If the Reacant is a Drug Class
I GMRAAR["C" D VACLASS(+GMRAAR,.GMRADRCL)
;If the Reactant is a entry in the GMR ALLERGY file
I GMRAAR["A" D
.S Y=0 F S Y=$O(^GMRD(120.82,+GMRAAR,"ING",Y)) Q:Y'>0 I $D(^GMRD(120.82,+GMRAAR,"ING",Y,0)),+^(0)>0 S GMRAING(+^(0))=""
.S Y=0 F S Y=$O(^GMRD(120.82,+GMRAAR,"CLASS",Y)) Q:Y'>0 I $D(^GMRD(120.82,+GMRAAR,"CLASS",Y,0)),+^(0)>0 S GMRADRCL(+^(0))=""
.Q
I GMRAAR["D" D
.S PSODRUG(+GMRAAR)=$P($G(^PSDRUG(+GMRAAR,0)),"^") ;ADD PSODRUG
.N PSODA
.S PSODA=+GMRAAR K ^TMP("PSO",$J) D ^PSONGR F Y=0:0 S Y=$O(^TMP("PSO",$J,Y)) Q:Y'>0 S GMRAING(Y)=""
.N GMRAX,GMRAY
.S GMRAX=$P($G(^PSDRUG(+GMRAAR,"ND")),U,6) S:GMRAX>0 GMRADRCL(GMRAX)="" Q
.S GMRAX=$P($G(^PSDRUG(+GMRAAR,0)),U,2) Q:GMRAX=""
.S GMRAY=$O(^PS(50.605,"B",GMRAX,"")) S:GMRAY>0 GMRADRCL(GMRAY)=""
.Q
I GMRAAR["G" D
.N PSNDA
.S PSNDA=+GMRAAR K ^TMP("PSN",$J) D ^PSNNGR F Y=0:0 S Y=$O(^TMP("PSN",$J,Y)) Q:Y'>0 S GMRAING(Y)=""
.; all classes for NDF entry returned in GMRADRCL
.N CLASS
.S CLASS=$$CLIST^PSNAPIS(+GMRAAR,.GMRADRCL)
.Q
K ^TMP("PSO",$J),^TMP("PSN",$J),PSOID,PSNID
Q
;
VACLASS(ENTRY,PICK) ;EXPAND THE CLASSES
N TEMP
D TEMP
N CHILD
S CHILD=0 F S CHILD=$O(TEMP(ENTRY,CHILD)) Q:CHILD="" D
.S PICK(CHILD)="" ;$P(^PS(50.605,CHILD,0),"^",1)
.D:CHILD'=ENTRY PICK1(CHILD)
Q
;
TEMP ; MAKE YOUR TEMP GLOBAL OF TEMP(PARENT,CHILD)=""
N CHILD,PARENT
S CHILD=0 F S CHILD=$O(^PS(50.605,CHILD)) Q:CHILD'=+CHILD D
.S TEMP(CHILD,CHILD)="" ;ALWAYS SET THE ENTRY TO ITSELF
.S PARENT=$P(^PS(50.605,CHILD,0),"^",3)
.Q:'PARENT
.S TEMP(PARENT,CHILD)=""
Q
;
PICK1(ENTRY) ;Part of expansion
N CHILD
S CHILD=0 F S CHILD=$O(TEMP(ENTRY,CHILD)) Q:CHILD="" D
.S PICK(CHILD)=$P(^PS(50.605,CHILD,0),"^",1)
.D:CHILD'=ENTRY PICK2(CHILD)
Q
;
PICK2(ENTRY) ;Part of expansion
N CHILD
S CHILD=0 F S CHILD=$O(TEMP(ENTRY,CHILD)) Q:CHILD="" D
.S PICK(CHILD)=$P(^PS(50.605,CHILD,0),"^",1)
.D:CHILD'=ENTRY PICK3(CHILD)
Q
;
PICK3(ENTRY) ;THIS SHOULD BE EN
N CHILD S CHILD=0 F S CHILD=$O(TEMP(ENTRY,CHILD)) Q:CHILD="" D
.S PICK(CHILD)=$P(^PS(50.605,CHILD,0),"^",1)
Q
;
;
TEST(AZOIT) ;CHECK FOR ERRORS AND VERIFED STATUS
N AZOCHECK,INAC
S AZOCHECK=0
S:+$G(^GMR(120.8,AZOIT,"ER")) AZOCHECK=1
;S:$P(^GMR(120.8,AZOIT,0),U,16)'="1" AZOCHECK=1
S INAC=$$INACTIVE^GMRADSP6(AZOIT) ;PATCH 1008
I +INAC S AZOCHECK=1 ;Quit if inactive
Q AZOCHECK
BPXRMAL1 ;IHS/MSC/MGH - Handle Allergy findings for drugs ;30-Mar-2018 14:29;DU
+1 ;;2.0;CLINICAL REMINDERS;**1001,1002,1009**;Feb 04, 2005;Build 17
+2 ;--------------------------------------------------------------
+3 ;Patch 1009 added Statin drugs
+4 ;ROUTINE TO TEST ALLERGY STATUS
+5 ;ENTRY POINT REM JUST NEEDS THE PSODFN.NOT NECESSARILY THE TERM WILL FIND ALL
+6 ;TERMS THAT HAVE DRUGS IN THEM EITHER DRUG OR VA GENERIC
+7 QUIT
+8 ;
ASAREM(PSODFN,TEST,DATE,VALUE,TEXT) ; EP ASPIRIN COMPUTED ALLERGY CHECK RETURN TEST=1 IF ALLERGY
+1 SET TERM="IHS-ASPIRIN"
+2 DO REM(PSODFN,.TEST,.DATE,.VALUE,.TEXT)
+3 QUIT
+4 ;
STATREM(PSODFN,TEST,DATE,VALUE,TEXT) ;EP Statin computed allergy check added patch 1009
+1 SET TERM="IHS-STATIN DRUGS"
+2 DO REM(PSODFN,.TEST,.DATE,.VALUE,.TEXT)
+3 QUIT
+4 ;
AAREM(PSODFN,TEST,DATE,VALUE,TEXT) ; EP ACE/ARB COMPUTED ALLERGY CHECK RETURN TEST=1 IF ALLERGY
+1 NEW VALUE,TEST1,TEXT1,TEST2,TEXT2
+2 SET VALUE=""
SET DATE=DT
SET CHECK=""
+3 SET I="CV800"
+4 SET CHECK=$$FIND1^DIC(50.605,"","MX",I)_"C"
+5 IF CHECK=""
SET TEST=0
SET TEXT="VA DRUG CLASSES FOR 'CV800' NOT DEFINED!!"
QUIT
+6 DO ALLER(PSODFN,CHECK,.TEST1,.TEXT1)
+7 SET I="CV805"
+8 SET CHECK=$$FIND1^DIC(50.605,"","MX",I)_"C"
+9 IF CHECK=""
SET TEST=0
SET TEXT="VA DRUG CLASSES FOR 'CV805' NOT DEFINED!!"
QUIT
+10 DO ALLER(PSODFN,CHECK,.TEST2,.TEXT2)
+11 IF TEST1=1&(TEST2=1)
SET TEST=1
SET TEXT="ALLERGIES TO BOTH"
+12 IF '$TEST
SET TEST=0
SET TEXT="ALLERGIES TO BOTH CLASSES NOT FOUND"
+13 QUIT
+14 ;
REM(PSODFN,TEST,DATE,VALUE,TEXT) ; EP YOU GIVE THE PSODFN AND THE TERM DEFINDED BELOW
+1 ;MAIN ENTRY POINT ABOVE GIVEN PSODFN AND TERM
+2 ;TERM IS THE NAME OF THE REMINDER TERM TO QUERY
+3 ;IF I DON'T HAVE A TERM I'LL QUERY THE REMINDER TERM LOOKING FOR A DRUG OR VA DRUG TERM
+4 ;--------------------------------------------------------------------
+5 SET DATE=DT
SET VALUE=""
+6 NEW RESULT,TERMLONG,TERMS,I
+7 ;ADD THIS BELOW FOR CASE WHEN NO TERM DEFINED IHS/OKCAO/POC 11/7/2006
IF $GET(TERM)']""
Begin DoDot:1
+8 DO LIST^DIC(811.902,","_PXRMITEM_",",.01,"I",,,,,,,"TERMLONG")
+9 MERGE TERMS=TERMLONG("DILIST",1)
+10 ;JUST THE TERMS
SET I=""
FOR
SET I=$ORDER(TERMS(I))
IF I=""
QUIT
IF $PIECE(TERMS(I),";",2)'="PXRMD(811.5,"
KILL TERMS(I)
+11 ;NO VALID TERM DRUG OR VA DRUG FINDINGS IN THE REMINDER TERM
IF '$DATA(TERMS)
SET TEST=0
SET TEXT="THERE ARE NO VALID TERM FINDINGS (DRUG OR VA DRUG) IN THE REMINDER TAXONMY "_$$GET1^DIQ(811.9,PXRMITEM_",",.01)
QUIT
+12 ;QUIT IS TEST=1 FOUND ALLERGY TO SOMETHING DON'T OVERWRITE IT
SET I=""
FOR
SET I=$ORDER(TERMS(I))
IF I=""
QUIT
IF $GET(TEST)
QUIT
SET TERM="`"_$PIECE(TERMS(I),";")
Begin DoDot:2
+13 DO TERM(TERM,.RETURN)
+14 ;NO VALID FINDINGS IN THE REMINDER TERM
IF '$GET(RETURN)
SET TEST=0
SET TEXT="THERE ARE NO VALID FINDINGS IN THE REMINDER TAXONMY "_$$GET1^DIQ(811.9,PXRMITEM_",",.01)
QUIT
+15 DO ALLER(PSODFN,RETURN,.TEST,.TEXT)
End DoDot:2
End DoDot:1
+16 ;I $G(TERM)']"" S TEST=0,TEXT="NEED TO DEFINE THE TERM. CALL PROGRAMMER!" Q
+17 ;GIVE THE TERM ALSO <---
+18 IF '$TEST
Begin DoDot:1
+19 DO TERM(TERM,.RETURN)
+20 ;NO VALID FINDINGS IN THE REMINDER TERM
IF '$GET(RETURN)
SET TEST=0
SET TEXT="THERE ARE NO VALID FINDINGS IN THE REMINDER TAXONMY "_TERM
QUIT
+21 DO ALLER(PSODFN,RETURN,.TEST,.TEXT)
End DoDot:1
+22 QUIT
+23 ;END OF CHANGES IHS/OKCAO/POC 11/7/2006
+24 ;
TERM(TERM,RETURN) ;GIVEN REMINDER TERM RETURN THE STRING TO PASS TO ALLER
+1 ;FINDINGS MUST BE FROM THE DRUG FILE!!
+2 NEW TARLONG,IEN,FINDINGS,TERMIEN
+3 KILL RETURN
+4 ;REMINDER TERM
SET TERMIEN=$$FIND1^DIC(811.5,"","MX",TERM)
+5 IF 'TERMIEN
SET TEST=0
SET TEXT="NO REMINDER TERM "_TERM_" FOUND!!"
QUIT
+6 DO LIST^DIC(811.52,","_TERMIEN_",",".01","I","","","","",,"","TARLONG")
+7 ;FINDINGS FOR THIS REMINDER
MERGE FINDINGS=TARLONG("DILIST",1)
+8 SET IEN=""
FOR
SET IEN=$ORDER(FINDINGS(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+9 ;WE'LL ONLY LOOK AT ENTRIES POINTING TO DRUGS OR VA GENERICS NOT VA CLASSES IHS/OKCAO/POC 5/11/2006
+10 SET RETURN=$GET(RETURN)_"^"_$SELECT(FINDINGS(IEN)["PSDRUG":+FINDINGS(IEN)_"D",FINDINGS(IEN)["PSNDF(50.6,":+FINDINGS(IEN)_"G",1:"")
End DoDot:1
+11 ;GET RID OF FIRST '^')
SET RETURN=$EXTRACT($GET(RETURN),2,$LENGTH($GET(RETURN)))
+12 QUIT
+13 ;
ALLER(PSODFN,CHECK,TEST,TEXT) ; EP
+1 ;TEST =1 IF ALLERGY 0 IF NO ALLERGY TEXT IS WRITTEN TEXT
+2 ;PSODFN=DFN CHECK=IS THE ENTITY TO CHECK SEE STING TAG
+3 ;CHECK CAN BE MUTIPLES SEPARATED BY '^'
+4 ;INPUT GMRAAR LIKE THIS FOR FILE 120.82=IEN_"A", FILE 50=IEN_"D", FILE 50.6=IEN_"G", FILE 50.605=IEN_"C", FILE 50.416=IEN_"I"
+5 ;EXAMPLE CHECK="305D^276C WOULD BE IEN 305 IN FILE 50 AND IEN 276 IN 50.605
+6 ;-------------------------------------------------------------------
+7 NEW REACTION
+8 SET TEST=0
SET TEXT=""
+9 SET REACTION=$$NKA^GMRANKA(PSODFN)
+10 IF REACTION=""
SET TEXT="NO ALLERGY INFORMATION FOR THIS PATIENT HAS BEEN RECORDED"
QUIT
+11 IF REACTION=0
SET TEXT="THIS PATIENT HAS BEEN RECORDED AS 'NKA'"
QUIT
+12 KILL ING,CLASS,DRUG
+13 FOR I=1:1
SET GMRAAR=$PIECE(CHECK,"^",I)
IF GMRAAR=""
QUIT
DO STING(GMRAAR,.ING,.CLASS,.DRUG)
+14 ;NOW YOU HAVE ARRAY OF ING-VA INGREDIENT IEN, CLASS- VA DRUG CLASS IENS, AND DRUG-DRUG IEN
+15 ;START LOOPING THROUGH THE GMR(120.8 GLOBAL
+16 NEW IEN
+17 SET IEN=0
FOR
SET IEN=$ORDER(^GMR(120.8,"B",PSODFN,IEN))
IF IEN'=+IEN!TEST
QUIT
Begin DoDot:1
+18 ;NOT VERIFIED OR IS AN ERROR OR IS INACTIVE
IF $$TEST(IEN)
QUIT
+19 NEW INGIEN
+20 SET INGIEN=0
FOR
SET INGIEN=$ORDER(^GMR(120.8,IEN,2,"B",INGIEN))
IF INGIEN'=+INGIEN!TEST
QUIT
Begin DoDot:2
+21 IF $DATA(ING(INGIEN))
SET TEST=1
SET DATE=DT
SET TEXT="PT ALLERGIC TO DRUG INGREDIENT "_$PIECE($GET(^PS(50.416,INGIEN,0)),"^")_" IN PATIENT ALLERGY "_$PIECE($GET(^GMR(120.8,IEN,0)),"^",2)_"-"_IEN
End DoDot:2
+22 IF TEST
QUIT
+23 NEW CLASSIEN
+24 SET CLASSIEN=0
FOR
SET CLASSIEN=$ORDER(^GMR(120.8,IEN,3,"B",CLASSIEN))
IF CLASSIEN'=+CLASSIEN!TEST
QUIT
Begin DoDot:2
+25 IF $DATA(CLASS(CLASSIEN))
SET TEST=1
SET DATE=DT
SET TEXT="PT ALLERGIC TO DRUG CLASS "_$PIECE($GET(^PS(50.605,CLASSIEN,0)),"^")_" IN PATIENT ALLERGY "_$PIECE($GET(^GMR(120.8,IEN,0)),"^",2)_"-"_IEN
End DoDot:2
+26 IF TEST
QUIT
+27 NEW DRUGIEN
+28 SET DRUGIEN=$PIECE(^GMR(120.8,IEN,0),"^",3)
+29 IF DRUGIEN["PSDRUG("
IF $DATA(DRUG(+DRUGIEN))
SET TEST=1
SET DATE=DT
SET TEXT="PT ALLERGIC TO DRUG "_$PIECE($GET(^PSDRUG(+DRUGIEN,0)),"^")_" IN PATIENT ALLERGY "_$PIECE($GET(^GMR(120.8,IEN,0)),"^",2)_"-"_IEN
End DoDot:1
+30 QUIT
+31 ;
STING(GMRAAR,GMRAING,GMRADRCL,PSODRUG) ;
+1 ;INPUT GMRAAR LIKE THIS FOR FILE 120.82=IEN_"A", FILE 50=IEN_"D", FILE 50.6=IEN_"G", FILE 50.605=IEN_"C", FILE 50.416=IEN_"I"
+2 ;GMRAING=DRUG INGREDIENTS, AND GMRADRCL=VA DRUG CLASS, AND PSODRUG=DRUG ARE RETURNED IN ARRAY
+3 ;K GMRAING,GMRADRCL ;GMRAING=DRUG INGREDIENTS GMRADRCL=CLASSES
+4 ;------------------------------------------------------------------------
+5 NEW Y
+6 IF GMRAAR["I"
SET GMRAING(+GMRAAR)=""
+7 ;If the Reacant is a Drug Class
+8 IF GMRAAR["C"
DO VACLASS(+GMRAAR,.GMRADRCL)
+9 ;If the Reactant is a entry in the GMR ALLERGY file
+10 IF GMRAAR["A"
Begin DoDot:1
+11 SET Y=0
FOR
SET Y=$ORDER(^GMRD(120.82,+GMRAAR,"ING",Y))
IF Y'>0
QUIT
IF $DATA(^GMRD(120.82,+GMRAAR,"ING",Y,0))
IF +^(0)>0
SET GMRAING(+^(0))=""
+12 SET Y=0
FOR
SET Y=$ORDER(^GMRD(120.82,+GMRAAR,"CLASS",Y))
IF Y'>0
QUIT
IF $DATA(^GMRD(120.82,+GMRAAR,"CLASS",Y,0))
IF +^(0)>0
SET GMRADRCL(+^(0))=""
+13 QUIT
End DoDot:1
+14 IF GMRAAR["D"
Begin DoDot:1
+15 ;ADD PSODRUG
SET PSODRUG(+GMRAAR)=$PIECE($GET(^PSDRUG(+GMRAAR,0)),"^")
+16 NEW PSODA
+17 SET PSODA=+GMRAAR
KILL ^TMP("PSO",$JOB)
DO ^PSONGR
FOR Y=0:0
SET Y=$ORDER(^TMP("PSO",$JOB,Y))
IF Y'>0
QUIT
SET GMRAING(Y)=""
+18 NEW GMRAX,GMRAY
+19 SET GMRAX=$PIECE($GET(^PSDRUG(+GMRAAR,"ND")),U,6)
IF GMRAX>0
SET GMRADRCL(GMRAX)=""
QUIT
+20 SET GMRAX=$PIECE($GET(^PSDRUG(+GMRAAR,0)),U,2)
IF GMRAX=""
QUIT
+21 SET GMRAY=$ORDER(^PS(50.605,"B",GMRAX,""))
IF GMRAY>0
SET GMRADRCL(GMRAY)=""
+22 QUIT
End DoDot:1
+23 IF GMRAAR["G"
Begin DoDot:1
+24 NEW PSNDA
+25 SET PSNDA=+GMRAAR
KILL ^TMP("PSN",$JOB)
DO ^PSNNGR
FOR Y=0:0
SET Y=$ORDER(^TMP("PSN",$JOB,Y))
IF Y'>0
QUIT
SET GMRAING(Y)=""
+26 ; all classes for NDF entry returned in GMRADRCL
+27 NEW CLASS
+28 SET CLASS=$$CLIST^PSNAPIS(+GMRAAR,.GMRADRCL)
+29 QUIT
End DoDot:1
+30 KILL ^TMP("PSO",$JOB),^TMP("PSN",$JOB),PSOID,PSNID
+31 QUIT
+32 ;
VACLASS(ENTRY,PICK) ;EXPAND THE CLASSES
+1 NEW TEMP
+2 DO TEMP
+3 NEW CHILD
+4 SET CHILD=0
FOR
SET CHILD=$ORDER(TEMP(ENTRY,CHILD))
IF CHILD=""
QUIT
Begin DoDot:1
+5 ;$P(^PS(50.605,CHILD,0),"^",1)
SET PICK(CHILD)=""
+6 IF CHILD'=ENTRY
DO PICK1(CHILD)
End DoDot:1
+7 QUIT
+8 ;
TEMP ; MAKE YOUR TEMP GLOBAL OF TEMP(PARENT,CHILD)=""
+1 NEW CHILD,PARENT
+2 SET CHILD=0
FOR
SET CHILD=$ORDER(^PS(50.605,CHILD))
IF CHILD'=+CHILD
QUIT
Begin DoDot:1
+3 ;ALWAYS SET THE ENTRY TO ITSELF
SET TEMP(CHILD,CHILD)=""
+4 SET PARENT=$PIECE(^PS(50.605,CHILD,0),"^",3)
+5 IF 'PARENT
QUIT
+6 SET TEMP(PARENT,CHILD)=""
End DoDot:1
+7 QUIT
+8 ;
PICK1(ENTRY) ;Part of expansion
+1 NEW CHILD
+2 SET CHILD=0
FOR
SET CHILD=$ORDER(TEMP(ENTRY,CHILD))
IF CHILD=""
QUIT
Begin DoDot:1
+3 SET PICK(CHILD)=$PIECE(^PS(50.605,CHILD,0),"^",1)
+4 IF CHILD'=ENTRY
DO PICK2(CHILD)
End DoDot:1
+5 QUIT
+6 ;
PICK2(ENTRY) ;Part of expansion
+1 NEW CHILD
+2 SET CHILD=0
FOR
SET CHILD=$ORDER(TEMP(ENTRY,CHILD))
IF CHILD=""
QUIT
Begin DoDot:1
+3 SET PICK(CHILD)=$PIECE(^PS(50.605,CHILD,0),"^",1)
+4 IF CHILD'=ENTRY
DO PICK3(CHILD)
End DoDot:1
+5 QUIT
+6 ;
PICK3(ENTRY) ;THIS SHOULD BE EN
+1 NEW CHILD
SET CHILD=0
FOR
SET CHILD=$ORDER(TEMP(ENTRY,CHILD))
IF CHILD=""
QUIT
Begin DoDot:1
+2 SET PICK(CHILD)=$PIECE(^PS(50.605,CHILD,0),"^",1)
End DoDot:1
+3 QUIT
+4 ;
+5 ;
TEST(AZOIT) ;CHECK FOR ERRORS AND VERIFED STATUS
+1 NEW AZOCHECK,INAC
+2 SET AZOCHECK=0
+3 IF +$GET(^GMR(120.8,AZOIT,"ER"))
SET AZOCHECK=1
+4 ;S:$P(^GMR(120.8,AZOIT,0),U,16)'="1" AZOCHECK=1
+5 ;PATCH 1008
SET INAC=$$INACTIVE^GMRADSP6(AZOIT)
+6 ;Quit if inactive
IF +INAC
SET AZOCHECK=1
+7 QUIT AZOCHECK
