APSQALLE ;IHS/ASDS/ENM/POC - ROUTINE TO CHECK FOR ALLERGIES [ 01/13/2003 12:38 PM ]
;;6.0;IHS PHARMACY MODIFICATIONS;**3,4**;11/27/2002
;;A LITTLE SOMETHING EXTRA
Q
EN ;EP HERE WE START
W !!,"CHECKING FOR DRUG ALLERGIES..." ;FIX TYPO IHS/OKCAO/POC 11/27/2002
Q:'$D(PSODFN)
Q:'$D(^GMR(120.8,"B",PSODFN))
Q:$O(^GMR(120.8,"ANKA",PSODFN,""))="n" ;PT HAS NKA XREF
S AZOQUIT=0 ;AZOQUIT=1=NONDF AZOQUIT=2=NO CLASS
;AZOXREF IS SPECIAL XREF OF DRUG INGREDIENT FILE
S AZOXREF=$G(PSODRUG("NDF"),0) S:AZOXREF="" AZOXREF=0,AZOQUIT=1
IF '(AZOXREF?1.N1"A"1.N) S AZOXREF=0,AZOQUIT=1 ;GOT TO KNOW WHEN NO NDF
;S:AZOXREF="" AZOXREF=0 ;JUST TO BE SAFE
S AZOCLASS=$G(PSODRUG("VA CLASS"),0) S:AZOCLASS="" AZOCLASS=0
S:AZOCLASS=0 AZOQUIT=2
D:AZOQUIT=0 XREF ;GOT A SPECIAL XREF
D:AZOQUIT=1 CLASS ;GOT A CLASS ONLY
D:AZOQUIT=2 DRUG ;GOT A DRUG NAME ONLY
;WORK THRU THE PATIENT ALLERGY FILE USING EITHER SPECIAL XREF OR CLASS
D FULL:AZOQUIT=0,HALF:AZOQUIT=1,QUAR:AZOQUIT=2,NONE:AZOQUIT=3
D END
Q
;SUBROUTINES
;
NONE ;SHOULD NOT GET HERE BUT!!!
END ;CLEAN UP TIME
D EN^XBVK("AZO")
Q
XREF ;GET THE DRUG COMPONENTS TO BE CHECKED
S AZODRCOM=0 F I=1:1 S AZODRCOM=$O(^PS(50.416,"APD",AZOXREF,AZODRCOM)) Q:AZODRCOM="" D
.IF $P(^PS(50.416,AZODRCOM,0),U,2)]"" S AZODREF(I)=$P(^(0),U,2) ;THIS IS A LITTLE TRICKY
.E S AZODREF(I)=AZODRCOM
.Q
IF '$D(AZODREF) S AZO("MESS")="THERE IS NO DRUG COMPONENT (NO NDF ENTRY) FOR THE DRUG "_PSODRUG("NAME")_". IT CANNOT BE CHECKED WITH CERTAINTY FOR ALLERGIES.",AZOQUIT=1 D CLASS ;SEE IF CAN BE CHECKED WITH CLASS
Q
;
CLASS ;CHECKS FOR CLASS IF NO ENTRY IN NDF
;S AZOCLASS=$G(PSODRUG("VA CLASS"),0) S:AZOCLASS="" AZOCLASS=0
;IF AZOCLASS=0 S AZO("MESS")="THERE IS NO DRUG COMPONENT (NO NDF ENTRY) OR CLASS FOR THE DRUG "_PSODRUG("NAME")_". IT CANNOT BE CHECKED PROPERLY FOR ALLERGIES.",AZOQUIT=2 D DRUG
;WRITES MESSAGE TO BE DISPLAY IF GOT CLASS ONLY
S AZO("MESS")="THERE IS NO DRUG COMPONENT (NO NDF ENTRY) FOR THE DRUG "_PSODRUG("NAME")_". IT CANNOT BE CHECKED PROPERLY FOR ALLERGIES."
Q
;
DRUG ;GO HERE IF NO NDF OR CLASS
IF AZOCLASS=0 S AZOQUIT=2,AZO("MESS")="THERE IS NO DRUG COMPONENT (NO NDF ENTRY) OR CLASS FOR THE DRUG "_PSODRUG("NAME")_". IT CANNOT BE CHECKED PROPERLY FOR ALLERGIES."
Q
;
;
FULL ;
S AZOALLD=0 F S AZOALLD=$O(^GMR(120.8,"API",PSODFN,AZOALLD)) Q:AZOALLD="" D ;AZOALLD=SPECIAL XREF FOR ALLERGY IN FILE 50.416
.S AZOALLI=$O(^GMR(120.8,"API",PSODFN,AZOALLD,""))
.;Q:$D(^GMR(120.8,AZOALLI,"ER")) ;ENTERED IN ERROR NODE
.Q:$$TEST(AZOALLI)
.S AZOALLDR=$S($P(^PS(50.416,AZOALLD,0),U,2)["":$P(^(0),U,2),1:AZOALLD) ;THIS IS TRICKY NOTE SOME DRUG INGREDIENTS MAY "POINT" TO OTHER DRUG INGREDEINTS
.;NOW TO LOOP THRU OUR DRUG BEING CHECKED=AZODREF(I)'S WITH THIS AZOALLDR=ALLERGY DRUG
.S I=0 F S I=$O(AZODREF(I)) Q:I="" D
..IF AZODREF(I)=AZOALLD S AZOHIT=1,AZO("HITE"_$P(^GMR(120.8,AZOALLI,0),U,2))="THE DRUG "_PSODRUG("NAME")_" IS 'MATCHED' WITH PATIENT'S ALLERGY FILE NAME "_$P(^GMR(120.8,AZOALLI,0),U,2) ;GET ONLY 1 MSG FOR A DRUG W/ MULTI DRUG COMPONENTS
..Q
.Q
D:$G(AZOHIT) ASK
KILL AZOHIT
Q
;
HALF ;THIS IS USED TO CHECK IF ONLY HAVE A CLASS
;DONE LIKE FULL EXCEPT USE APC XREF FOR CLASS
S AZOALLC=0 F S AZOALLC=$O(^GMR(120.8,"APC",PSODFN,AZOALLC)) Q:AZOALLC="" D
.S AZOALLI=$O(^GMR(120.8,"APC",PSODFN,AZOALLC,""))
.;Q:$D(^GMR(120.8,AZOALLC,"ER"))
.Q:$$TEST(AZOALLI)
.IF AZOCLASS=AZOALLC S AZOHIT=1,AZO("HITC"_AZOALLI)="THE DRUG "_PSODRUG("NAME")_" IS 'CLASSED' WITH PATIENT ALLERGY FILE AS "_$P(^GMR(120.8,AZOALLI,0),U,2)
.Q
D:$G(AZOHIT) ASK
K AZOHIT
Q
;
QUAR ;WELL NOTHING IS LEFT BUT TO CHECK THE DRUG ITSELF
S AZODRUG=PSODRUG("IEN") ;OUR DRUG TO COMPARE WITH ALLERGIES
S AZODRUGC=0 F S AZODRUGC=$O(^GMR(120.8,"B",PSODFN,AZODRUGC)) Q:AZODRUGC="" D
.Q:$$TEST(AZODRUGC)
.IF $P($P(^GMR(120.8,AZODRUGC,0),U,3),";",2)="PSDRUG(" S AZODRUGI=+$P(^(0),U,3) IF $G(AZODRUGI)=AZODRUG D
..S AZOHIT=1,AZO("HITD"_$P(^GMR(120.8,AZODRUGC,0),U,2))="THE DRUG "_PSODRUG("NAME")_" IS 'IDENTICAL' WITH PATIENT ALLERGY FILE NAME "_$P(^GMR(120.8,AZODRUGC,0),U,2)
..Q
.Q
D:$G(AZOHIT) ASK
K AZOHIT
Q
;
ASK ;ASK WHAT IS TO BE DONE
;LETS DO REVERSE VIDEO
S X="IORVON;IORVOFF" D ENDR^%ZISS
;FIRST WRITE MESSAGES
S I="" F S I=$O(AZO(I)) Q:I="" W:I="MESS" IORVON W !,*7,AZO(I) W:I="MESS" IORVOFF
;S DIR("A")="WHAT IS YOUR POISON? "
S DIR("A")="WHAT IS YOUR CHOICE? "
S DIR("A",1)="1 DO YOU WANT TO DELETE THIS DRUG?"
S DIR("A",2)="2 DO AN INTERVENTION?"
S DIR("A",3)="3 DO BOTH 1 AND 2?"
S DIR("A",4)="4 JUST CONTINUE?"
S DIR("B")=1
S DIR(0)="N^1:4:0"
D ^DIR
;IF (Y="")!(Y["^") S Y=1
IF $D(DIRUT)!($D(DIROUT)) S Y=1
K DIR,DTOUT,DIRUT,DUOUT,DIROUT
D @Y
Q
;
TEST(AZOIT) ;CHECK FOR ERRORS AND VERIFED STATUS
S AZOCHECK=0
S:$D(^GMR(120.8,AZOIT,"ER")) AZOCHECK=1
S:$P(^GMR(120.8,AZOIT,0),U,16)'="1" AZOCHECK=1
Q AZOCHECK
;
1 ;DELETE THE DRUG
S PSORX("DFLG")=1,DGI=""
Q
2 ;DO AN INTERVENTION
S PSORX("INTERVENE")=3,DGI=""
Q
3 ;DO BOTH 1 AND 2
D 2,1
Q
4 ;DO NOTHING
Q
APSQALLE ;IHS/ASDS/ENM/POC - ROUTINE TO CHECK FOR ALLERGIES [ 01/13/2003 12:38 PM ]
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;**3,4**;11/27/2002
+2 ;;A LITTLE SOMETHING EXTRA
+3 QUIT
EN ;EP HERE WE START
+1 ;FIX TYPO IHS/OKCAO/POC 11/27/2002
WRITE !!,"CHECKING FOR DRUG ALLERGIES..."
+2 IF '$DATA(PSODFN)
QUIT
+3 IF '$DATA(^GMR(120.8,"B",PSODFN))
QUIT
+4 ;PT HAS NKA XREF
IF $ORDER(^GMR(120.8,"ANKA",PSODFN,""))="n"
QUIT
+5 ;AZOQUIT=1=NONDF AZOQUIT=2=NO CLASS
SET AZOQUIT=0
+6 ;AZOXREF IS SPECIAL XREF OF DRUG INGREDIENT FILE
+7 SET AZOXREF=$GET(PSODRUG("NDF"),0)
IF AZOXREF=""
SET AZOXREF=0
SET AZOQUIT=1
+8 ;GOT TO KNOW WHEN NO NDF
IF '(AZOXREF?1.N1"A"1.N)
SET AZOXREF=0
SET AZOQUIT=1
+9 ;S:AZOXREF="" AZOXREF=0 ;JUST TO BE SAFE
+10 SET AZOCLASS=$GET(PSODRUG("VA CLASS"),0)
IF AZOCLASS=""
SET AZOCLASS=0
+11 IF AZOCLASS=0
SET AZOQUIT=2
+12 ;GOT A SPECIAL XREF
IF AZOQUIT=0
DO XREF
+13 ;GOT A CLASS ONLY
IF AZOQUIT=1
DO CLASS
+14 ;GOT A DRUG NAME ONLY
IF AZOQUIT=2
DO DRUG
+15 ;WORK THRU THE PATIENT ALLERGY FILE USING EITHER SPECIAL XREF OR CLASS
+16 IF AZOQUIT=0
DO FULL
IF AZOQUIT=1
DO HALF
IF AZOQUIT=2
DO QUAR
IF AZOQUIT=3
DO NONE
+17 DO END
+18 QUIT
+19 ;SUBROUTINES
+20 ;
NONE ;SHOULD NOT GET HERE BUT!!!
END ;CLEAN UP TIME
+1 DO EN^XBVK("AZO")
+2 QUIT
XREF ;GET THE DRUG COMPONENTS TO BE CHECKED
+1 SET AZODRCOM=0
FOR I=1:1
SET AZODRCOM=$ORDER(^PS(50.416,"APD",AZOXREF,AZODRCOM))
IF AZODRCOM=""
QUIT
Begin DoDot:1
+2 ;THIS IS A LITTLE TRICKY
IF $PIECE(^PS(50.416,AZODRCOM,0),U,2)]""
SET AZODREF(I)=$PIECE(^(0),U,2)
+3 IF '$TEST
SET AZODREF(I)=AZODRCOM
+4 QUIT
End DoDot:1
+5 ;SEE IF CAN BE CHECKED WITH CLASS
IF '$DATA(AZODREF)
SET AZO("MESS")="THERE IS NO DRUG COMPONENT (NO NDF ENTRY) FOR THE DRUG "_PSODRUG("NAME")_". IT CANNOT BE CHECKED WITH CERTAINTY FOR ALLERGIES."
SET AZOQUIT=1
DO CLASS
+6 QUIT
+7 ;
CLASS ;CHECKS FOR CLASS IF NO ENTRY IN NDF
+1 ;S AZOCLASS=$G(PSODRUG("VA CLASS"),0) S:AZOCLASS="" AZOCLASS=0
+2 ;IF AZOCLASS=0 S AZO("MESS")="THERE IS NO DRUG COMPONENT (NO NDF ENTRY) OR CLASS FOR THE DRUG "_PSODRUG("NAME")_". IT CANNOT BE CHECKED PROPERLY FOR ALLERGIES.",AZOQUIT=2 D DRUG
+3 ;WRITES MESSAGE TO BE DISPLAY IF GOT CLASS ONLY
+4 SET AZO("MESS")="THERE IS NO DRUG COMPONENT (NO NDF ENTRY) FOR THE DRUG "_PSODRUG("NAME")_". IT CANNOT BE CHECKED PROPERLY FOR ALLERGIES."
+5 QUIT
+6 ;
DRUG ;GO HERE IF NO NDF OR CLASS
+1 IF AZOCLASS=0
SET AZOQUIT=2
SET AZO("MESS")="THERE IS NO DRUG COMPONENT (NO NDF ENTRY) OR CLASS FOR THE DRUG "_PSODRUG("NAME")_". IT CANNOT BE CHECKED PROPERLY FOR ALLERGIES."
+2 QUIT
+3 ;
+4 ;
FULL ;
+1 ;AZOALLD=SPECIAL XREF FOR ALLERGY IN FILE 50.416
SET AZOALLD=0
FOR
SET AZOALLD=$ORDER(^GMR(120.8,"API",PSODFN,AZOALLD))
IF AZOALLD=""
QUIT
Begin DoDot:1
+2 SET AZOALLI=$ORDER(^GMR(120.8,"API",PSODFN,AZOALLD,""))
+3 ;Q:$D(^GMR(120.8,AZOALLI,"ER")) ;ENTERED IN ERROR NODE
+4 IF $$TEST(AZOALLI)
QUIT
+5 ;THIS IS TRICKY NOTE SOME DRUG INGREDIENTS MAY "POINT" TO OTHER DRUG INGREDEINTS
SET AZOALLDR=$SELECT($PIECE(^PS(50.416,AZOALLD,0),U,2)["":$PIECE(^(0),U,2),1:AZOALLD)
+6 ;NOW TO LOOP THRU OUR DRUG BEING CHECKED=AZODREF(I)'S WITH THIS AZOALLDR=ALLERGY DRUG
+7 SET I=0
FOR
SET I=$ORDER(AZODREF(I))
IF I=""
QUIT
Begin DoDot:2
+8 ;GET ONLY 1 MSG FOR A DRUG W/ MULTI DRUG COMPONENTS
IF AZODREF(I)=AZOALLD
SET AZOHIT=1
SET AZO("HITE"_$PIECE(^GMR(120.8,AZOALLI,0),U,2))="THE DRUG "_PSODRUG("NAME")_" IS 'MATCHED' WITH PATIENT'S ALLERGY FILE NAME "_$PIECE(^GMR(120.8,AZOALLI,0),U,2)
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 IF $GET(AZOHIT)
DO ASK
+12 KILL AZOHIT
+13 QUIT
+14 ;
HALF ;THIS IS USED TO CHECK IF ONLY HAVE A CLASS
+1 ;DONE LIKE FULL EXCEPT USE APC XREF FOR CLASS
+2 SET AZOALLC=0
FOR
SET AZOALLC=$ORDER(^GMR(120.8,"APC",PSODFN,AZOALLC))
IF AZOALLC=""
QUIT
Begin DoDot:1
+3 SET AZOALLI=$ORDER(^GMR(120.8,"APC",PSODFN,AZOALLC,""))
+4 ;Q:$D(^GMR(120.8,AZOALLC,"ER"))
+5 IF $$TEST(AZOALLI)
QUIT
+6 IF AZOCLASS=AZOALLC
SET AZOHIT=1
SET AZO("HITC"_AZOALLI)="THE DRUG "_PSODRUG("NAME")_" IS 'CLASSED' WITH PATIENT ALLERGY FILE AS "_$PIECE(^GMR(120.8,AZOALLI,0),U,2)
+7 QUIT
End DoDot:1
+8 IF $GET(AZOHIT)
DO ASK
+9 KILL AZOHIT
+10 QUIT
+11 ;
QUAR ;WELL NOTHING IS LEFT BUT TO CHECK THE DRUG ITSELF
+1 ;OUR DRUG TO COMPARE WITH ALLERGIES
SET AZODRUG=PSODRUG("IEN")
+2 SET AZODRUGC=0
FOR
SET AZODRUGC=$ORDER(^GMR(120.8,"B",PSODFN,AZODRUGC))
IF AZODRUGC=""
QUIT
Begin DoDot:1
+3 IF $$TEST(AZODRUGC)
QUIT
+4 IF $PIECE($PIECE(^GMR(120.8,AZODRUGC,0),U,3),";",2)="PSDRUG("
SET AZODRUGI=+$PIECE(^(0),U,3)
IF $GET(AZODRUGI)=AZODRUG
Begin DoDot:2
+5 SET AZOHIT=1
SET AZO("HITD"_$PIECE(^GMR(120.8,AZODRUGC,0),U,2))="THE DRUG "_PSODRUG("NAME")_" IS 'IDENTICAL' WITH PATIENT ALLERGY FILE NAME "_$PIECE(^GMR(120.8,AZODRUGC,0),U,2)
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 IF $GET(AZOHIT)
DO ASK
+9 KILL AZOHIT
+10 QUIT
+11 ;
ASK ;ASK WHAT IS TO BE DONE
+1 ;LETS DO REVERSE VIDEO
+2 SET X="IORVON;IORVOFF"
DO ENDR^%ZISS
+3 ;FIRST WRITE MESSAGES
+4 SET I=""
FOR
SET I=$ORDER(AZO(I))
IF I=""
QUIT
IF I="MESS"
WRITE IORVON
WRITE !,*7,AZO(I)
IF I="MESS"
WRITE IORVOFF
+5 ;S DIR("A")="WHAT IS YOUR POISON? "
+6 SET DIR("A")="WHAT IS YOUR CHOICE? "
+7 SET DIR("A",1)="1 DO YOU WANT TO DELETE THIS DRUG?"
+8 SET DIR("A",2)="2 DO AN INTERVENTION?"
+9 SET DIR("A",3)="3 DO BOTH 1 AND 2?"
+10 SET DIR("A",4)="4 JUST CONTINUE?"
+11 SET DIR("B")=1
+12 SET DIR(0)="N^1:4:0"
+13 DO ^DIR
+14 ;IF (Y="")!(Y["^") S Y=1
+15 IF $DATA(DIRUT)!($DATA(DIROUT))
SET Y=1
+16 KILL DIR,DTOUT,DIRUT,DUOUT,DIROUT
+17 DO @Y
+18 QUIT
+19 ;
TEST(AZOIT) ;CHECK FOR ERRORS AND VERIFED STATUS
+1 SET AZOCHECK=0
+2 IF $DATA(^GMR(120.8,AZOIT,"ER"))
SET AZOCHECK=1
+3 IF $PIECE(^GMR(120.8,AZOIT,0),U,16)'="1"
SET AZOCHECK=1
+4 QUIT AZOCHECK
+5 ;
1 ;DELETE THE DRUG
+1 SET PSORX("DFLG")=1
SET DGI=""
+2 QUIT
2 ;DO AN INTERVENTION
+1 SET PSORX("INTERVENE")=3
SET DGI=""
+2 QUIT
3 ;DO BOTH 1 AND 2
+1 DO 2
DO 1
+2 QUIT
4 ;DO NOTHING
+1 QUIT
