PSODGAL2 ; BIR/SAB - displays stored DRUG ALLERGY w/sign/symptoms ;10/27/11 02:22
;;7.0;OUTPATIENT PHARMACY;**390,411**;DEC 1997;Build 95
;Reference to ^PS(50.605, supported by DBIA 696
;Reference to GETOC4^OROCAPI1 supported by DBIA 5729
;Reference to ^ORD(100.05 supported by DBIA 5731
;Reference to ^GMRD(120.83 supported by DBIA 5767
;Reference to ^PS(50.416 supported by DBIA 4998
;
; This routine is called when the hidden option 'DA' is typed from the OP Medication screen
D FULL^VALM1
N ZORN,X,RET,DA,CNT,ZCNT,ZCNTT,XXI,ZZQ,DA,ZI,ZII,IT,SEVT,SEVN,ZFND,ORCT,ZWARN,DAT,CA,CAG,CLSTAT,PSOASORT,PROSPECT
N ZDA,ZDATB,ZST,ZQS,ZALL,ZRX,ZERO,PRTFLG,FLAG2,PSOASEV,PSOREA,PSOTYPE,PSORSITE,PSORDATA,ZIIEN,PSOPROV,PSOCAGNT
N PSOQUIT,DIWF,DIWL,DIWR,II,IEN
S (CNT,FLAG2,ZCNT,ZCNTT,ZFND,PSOQUIT,IEN)=0
I $G(PSODGCK) S ZRX=PSODGCRX
I '$G(PSODGCK) S ZRX=$P(PSOLST(ORN),"^",2)
S ZORN=$P(^PSRX(ZRX,"OR1"),"^",2)
I 'ZORN W !,"NO Drug Allergy Order Checks found for Rx#: "_$P(^PSRX(ZRX,0),"^") G EXT
K ^TMP("PSODAOCD",$J),^TMP("PSOAL",$J) D GETOC4^OROCAPI1(ZORN,.RET)
I $O(RET(ZORN,"DATA",""))="" S FLAG2=1
;
;
SORT ;build sort by severity, reactant/causitive agent
N ZIIEN,ZSIEN,ZSIGNS,SIGN,PSOASEV2,PSOZERO,SIGNS,PSOPTLOC,PSOINST,PSOREA2,PSOREAS,PSOREAB,PSODRGCL,PSODRCL2
N DRUGIEN,PSODCLAS,PSJREAB,PSJREAS
F ZI=0:0 S ZI=$O(RET(ZORN,"DATA",ZI)) Q:'ZI D:+$P(RET(ZORN,"DATA",ZI,1),";",2)=3
.I $G(RET(ZORN,"DATA",ZI,"OR",1,0))]"" S ^TMP("PSODAOCD",$J,"AOR",$G(RET(ZORN,"DATA",ZI,"OR",1,0)))=""
.S ZIIEN=0 F S ZIIEN=$O(^ORD(100.05,ZI,4,ZIIEN)) Q:ZIIEN="" I $D(^ORD(100.05,ZI,4,ZIIEN,0)) D
..Q:$P(^ORD(100.05,ZI,0),"^",3)["CPRS"
..S (PSOZERO,PSOREA,PSOTYPE,PSORSITE,PSOASEV,PSOASEV2,PROSPECT,DRUGIEN,PSJREAB,PSJREAS)=""
..S PSOZERO=$G(^ORD(100.05,ZI,4,ZIIEN,0))
..S PSOREAB=$P(PSOZERO,"^"),PSOREA2=$P($P(PSOZERO,"^",2),";",2)_$P($P(PSOZERO,"^",2),";"),PSOASEV=$P(PSOZERO,"^",7),PSOTYPE=$P(PSOZERO,"^",3)
..S PSORSITE=$P(PSOZERO,"^",4),PSOASEV2=$S(PSOASEV=3:"A",PSOASEV="2":"B",PSOASEV=1:"C",1:"D")
..I PSOREAB["/" D S PSOREA=$E(PSOREA,3,$L(PSOREA))
...F I=1:1 S PSOREAS=$P(PSOREAB,"/",I) Q:PSOREAS="" S PSOREA=PSOREA_"/ "_PSOREAS
..I PSOREAB'["/" S PSOREA=PSOREAB
..;
..;PROSPECTIVE DRUG/DISPENSED DRUG
..I $D(^ORD(100.05,ZI,5,1,0)) S DRUGIEN=^ORD(100.05,ZI,5,1,0)
..I DRUGIEN'="" S PROSPECT=$$GET1^DIQ(50,DRUGIEN,.01,"E") ;GENERIC NAME
..Q:PROSPECT=""
..;
..;DRUG CLASS
..S (PSOCAGNT,PSODRGCL,PSODCLAS,PSODRCL2)=""
..F ZZQ=0:0 S ZZQ=$O(^ORD(100.05,ZI,4,ZIIEN,1,ZZQ)) Q:'ZZQ!(ZZQ'?1N.N) D
...S PSODRCL2=^ORD(100.05,ZI,4,ZIIEN,1,ZZQ,0),PSODCLAS=1
...S PSODRGCL=PSODRGCL_"|"_$$GET1^DIQ(50.605,PSODRCL2,1)
..I PSODRGCL'?1A.AP S PSODRGCL=$E(PSODRGCL,2,999)
..S:PSODRGCL=""!(PSODRGCL="|") PSODRGCL="aaaa"
..S PSOCAGNT=$S(PSODRGCL'="aaaa":PSODRGCL,1:$P(PSOREA,"|",1))
..;
..;SITES
..I PSOTYPE="L" D ;local site
...S PSOPTLOC=$P(^PSRX(ZRX,2),"^",9),PSORSITE=$$GET1^DIQ(59,PSOPTLOC,100,"I")
..S PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,0)=ZIIEN_"^"_ZI_"^"_PSOCAGNT
..I '$D(PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,1)) S PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,1)=PSOTYPE_"|"_PSORSITE_"|"_$P(PSOZERO,"^",5),ZCNTT=1
..I $D(PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,1)) D
...S:PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,1)'[(PSOTYPE_"|"_PSORSITE_"|"_$P(PSOZERO,"^",5)) PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,1)=PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,1)_"^"_PSOTYPE_"|"_PSORSITE_"|"_$P(PSOZERO,"^",5)
..;
..;SIGNS AND SYMPTOMS
..S ZSIEN="" F S ZSIEN=$O(^ORD(100.05,ZI,4,ZIIEN,3,ZSIEN)) Q:ZSIEN="" I $D(^ORD(100.05,ZI,4,ZIIEN,3,ZSIEN,0)) D
...S ZSIGNS=^ORD(100.05,ZI,4,ZIIEN,3,ZSIEN,0)
...I '$D(PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,2)) S PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,2)=ZSIGNS Q
...S:PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,2)'[("|"_ZSIGNS_"|") PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,2)=PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,2)_"|"_ZSIGNS
;
I 'ZCNTT S FLAG2=1
I '$G(PSODGCK)&(FLAG2) W !,"NO Drug Allergy Order Checks found for Rx#: "_$P(^PSRX(ZRX,0),"^") G EXT
Q:FLAG2&($G(PSODGCK))
LOOP ;
;**** Begin looping through sort
S (PROSPECT,PSOASEV,PSOREA,PSOREA2,PSOTYPE,PSORSITE,PSORDATA,ZIIEN)=""
F S PROSPECT=$O(PSOASORT(PROSPECT)) Q:PROSPECT="" F S PSOASEV=$O(PSOASORT(PROSPECT,PSOASEV)) Q:PSOASEV="" D Q:$G(VALMBCK)="R"
.F S PSOREA=$O(PSOASORT(PROSPECT,PSOASEV,PSOREA)) Q:PSOREA="" F S PSOREA2=$O(PSOASORT(PROSPECT,PSOASEV,PSOREA,PSOREA2)) Q:PSOREA2="" D Q:$G(VALMBCK)="R"
..;F S ZIIEN=$O(PSOASORT(PROSPECT,PSOASEV,PSOREA,PSOREA2,ZIIEN)) Q:ZIIEN="" D Q:$G(VALMBCK)="R"
..S PSORDATA=PSOASORT(PROSPECT,PSOASEV,PSOREA,PSOREA2,0),(ZIIEN,XXI)=$P(PSORDATA,"^",1),ZI=$P(PSORDATA,"^",2)
..S PSORSITE=PSOASORT(PROSPECT,PSOASEV,PSOREA,PSOREA2,1)
..D ADOC Q:$G(VALMBCK)="R"
;
PRT ; print allergy information to screen
D FULL^VALM1 W @IOF
N ZZ,PRTFLG S PRTFLG=0
W $C(7),!,"A Drug-Allergy Reaction exists for this medication and/or class!",!
S ZZ="" F S ZZ=$O(^TMP("PSOAL",$J,ZZ)) Q:ZZ="" D G EXIT:PSOQUIT
.I PRTFLG,$G(^TMP("PSOAL",$J,ZZ,0))["Prospective Drug:" D EXT W !
.W !,^TMP("PSOAL",$J,ZZ,0) S PRTFLG=1 I ($Y+2)>IOSL D FF
;
K DIR,DUOUT,DIRUT,PSOASORT
G EXIT:PSOQUIT
I $G(PRTFLG) W ! D FF
G EXIT
Q
;
ADOC ;
N ING,SS,DC,OH,CAG,CAUS,SEVT,SEVN,ZALL,Z,ZX,ZALL,FIRST,DRUG,DRUGS,ZCX,PSOWCA,CAUS2,ZLOC,PSOCAR,FLAG,I,ZDATE
N SITE,SITET,SITED,I,ZDATA,PSOCSITE
I XXI'="" D:$P($G(^ORD(100.05,ZI,4,XXI,0)),"^")]""
.S (SEVT,SEVN,CAUS,CAUS2,PSOWCA,PSOCAR,OH,DRUG,DRUGS,X,ING,SS,DC,ZALL,ZLOC,ZDATE)=""
.S ZALL=$G(^ORD(100.05,ZI,4,XXI,0)),ZLOC=$P(ZALL,"^",3)
.S CAUS=$P(ZALL,"^",1),CAUS2=$P($P(ZALL,"^",2),";")
.S SEVT=$P(ZALL,"^",7),SEVN=$S(SEVT=1:"MILD",SEVT=2:"MODERATE",SEVT=3:"SEVERE",1:"Not Entered")
.S ^TMP("PSODAOCD",$J,"CA",CAUS)=""
.;
.;SITES
.S CAUS=$P(PSOREA," ~"),PSOCSITE=""
.I PSORSITE'["^" D
..S ZDATE=$P(PSORSITE,"|",3),ZDATE=$S(ZDATE'="":$E(ZDATE,4,5)_"/"_$E(ZDATE,6,7)_"/"_$E(ZDATE,2,3),1:"")
..S PSOCSITE=$$GET1^DIQ(4,$P(PSORSITE,"|",2),.01,"E")
..I PSOCSITE="" S PSOCSITE=$S(PSOCSITE'="":PSOCSITE,ZLOC="L":"LOCAL",ZLOC="R":"REMOTE",1:"Not Given")
..S PSOCAR=CAUS_" ("_PSOCSITE_" - "_ZDATE_")"
.I PSORSITE["^" D S:PSOCAR'="" PSOCAR=CAUS_" ("_$E(PSOCAR,3,999)_")"
..F I=1:1 S ZDATA=$P(PSORSITE,"^",I) Q:ZDATA="" S PSOCSITE="" D
...S ZDATE=$P(ZDATA,"|",3),ZDATE=$S(ZDATE'="":$E(ZDATE,4,5)_"/"_$E(ZDATE,6,7)_"/"_$E(ZDATE,2,3),1:"")
...S PSOCSITE=$$GET1^DIQ(4,$P(ZDATA,"|",2),.01,"E")
...I PSOCSITE="" S PSOCSITE=$S(PSOCSITE'="":PSOCSITE,ZLOC="L":"LOCAL",ZLOC="R":"REMOTE",1:"Not Given")
...S PSOCAR=PSOCAR_", "_PSOCSITE_" - "_ZDATE
.;
.;
.I PSOCAR="" S PSOCAR=CAUS
.;OP will only have one drug
.;I $D(^ORD(100.05,ZI,5,1,0)) S DRUGS=^ORD(100.05,ZI,5,1,0) I DRUGS'="" S DRUG=$$GET1^DIQ(50,DRUGS,.01,"E")
.;D GETS^DIQ(100.05,ZI,"50*","E","DRUGS") S:$D(DRUGS(100.06,"1,"_ZI_",",.01,"E")) DRUG=DRUGS(100.06,"1,"_ZI_",",.01,"E")
.S OH=$$UPPER($P(ZALL,"^",6)),^TMP("PSODAOCD",$J,"OH")=OH
.S IEN=$G(IEN)+1,^TMP("PSOAL",$J,IEN,0)=" Prospective Drug: "_PROSPECT,PRTFLG=1
.K ^UTILITY($J,"W") S DIWL=1,DIWR=58,DIWF=""
.S X=PSOCAR
.D ^DIWP S FIRST=1
.F ZCX=0:0 S ZCX=$O(^UTILITY($J,"W",1,ZCX)) Q:'ZCX S:$D(^UTILITY($J,"W",1,ZCX,0)) IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S(FIRST:" Causative Agent: "_^UTILITY($J,"W",1,ZCX,0),1:" "_^UTILITY($J,"W",1,ZCX,0)) S FIRST=0
.S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Historical/Observed: "_$S(OH="H":"HISTORICAL",OH="O":"OBSERVED",1:"Not Entered")
.S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Severity: "_$G(SEVN)
.K ^UTILITY($J,"W") S DIWL=1,DIWR=58,DIWF=""
.;
.; DRUG INGREDIENT
.S FLAG=0
.K ^TMP("PSODAOCD",$J,"DI")
.F ZZQ=0:0 S ZZQ=$O(^ORD(100.05,ZI,4,XXI,2,ZZQ)) Q:'ZZQ S ^TMP("PSODAOCD",$J,"DI",$P(^PS(50.416,$P(^ORD(100.05,ZI,4,XXI,2,ZZQ,0),"^"),0),"^"))="",FLAG=1
.S X=""
.F S ING=$O(^TMP("PSODAOCD",$J,"DI",ING)) Q:ING="" S X=X_", "_ING
.S X=$E(X,3,999)
.I X'="" D
..D ^DIWP
..S FIRST=1
..F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX S:$D(^UTILITY($J,"W",1,ZX,0)) IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S(FIRST:" Ingredients: "_^UTILITY($J,"W",1,ZX,0),1:" "_^UTILITY($J,"W",1,ZX,0)) S FIRST=0
.;
.; SIGNS/SYMPTOMS
.K ^UTILITY($J,"W"),^TMP("PSODAOCD",$J,"SS") S DIWL=1,DIWR=58,DIWF="",ING=""
.S (X,SIGNS,SIGN)="",SIGNS=$G(PSOASORT(PROSPECT,PSOASEV,PSOREA,PSOREA2,2))
.I SIGNS'="" F ZZQ=1:1 S SIGN=$P(SIGNS,"|",ZZQ) Q:SIGN="" D
..I $G(^GMRD(120.83,SIGN,0))]"" S ^TMP("PSODAOCD",$J,"SS",$P(^GMRD(120.83,SIGN,0),"^"))=""
.S X="",FIRST=1
.I $O(^TMP("PSODAOCD",$J,"SS",""))]"" S SS="" D
..F S SS=$O(^TMP("PSODAOCD",$J,"SS",SS)) Q:SS="" S X=X_", "_SS
.S X=$E(X,3,999) S:X="" X="None Entered" D ^DIWP
.F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S(FIRST:" Signs/Symptoms: "_^UTILITY($J,"W",1,ZX,0),1:" "_^UTILITY($J,"W",1,ZX,0)) S FIRST=0
.K ^UTILITY($J,"W")
.;
.; DRUG CLASS
.S DIWL=1,DIWR=58,DIWF="" K ^TMP("PSODAOCD",$J,"DC")
.F ZZQ=0:0 S ZZQ=$O(^ORD(100.05,ZI,4,XXI,1,ZZQ)) Q:'ZZQ S ^TMP("PSODAOCD",$J,"DC",$P(^ORD(100.05,ZI,4,XXI,1,ZZQ,0),"^"))=$P(^PS(50.605,$P(^ORD(100.05,ZI,4,XXI,1,ZZQ,0),"^"),0),"^")_" "_$P(^(0),"^",2)
.S X="",FIRST=1
.F DC=0:0 S DC=$O(^TMP("PSODAOCD",$J,"DC",DC)) Q:'DC S X=X_", "_^TMP("PSODAOCD",$J,"DC",DC) D
..I $L(X)>234 S X=$E(X,3,999) D ^DIWP S X=""
.I X'="" S X=$E(X,3,999)
.I X'="" D
..D ^DIWP
..F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S(FIRST:" Drug Class: "_^UTILITY($J,"W",1,ZX,0),1:" "_^UTILITY($J,"W",1,ZX,0)) S FIRST=0
..K ^UTILITY($J,"W") N Z,ZX
;
D INV ; intervention
Q
;
UPPER(PSOUCS) ;
Q $TR(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
LOWER(PSOLCS) ;
Q $TR(PSOLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
;
EXT ;
K DIR,DUOUT,DIRUT,ZFND
D FF
I $D(DIRUT) G EXIT
Q
EXIT ;
S VALMBCK="R" K DIR,DUOUT,DIRUT,ZFND,^TMP("PSODAOCD",$J),^TMP("PSOAL",$J),ZPGK
Q
;
INV ;display intervention
;changed to add Provider & Pharmacist and put in correct sequence [ST - 6.17.2014]
S IEN=$G(IEN)+1,^TMP("PSOAL",$J,IEN,0)=" "
K ^UTILITY($J,"W") S DIWL=1,DIWR=55,DIWF=""
S PSOPROV="",PSOPROV="N/A - Order Check Not Evaluated by Provider"
I $O(^TMP("PSODAOCD",$J,"AOR",""))]"" S PSOPROV=$O(^TMP("PSODAOCD",$J,"AOR",""))
S X=PSOPROV,FIRST=1 D ^DIWP
F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S(FIRST:"Provider Override Reason: "_^UTILITY($J,"W",1,ZX,0),1:" "_^UTILITY($J,"W",1,ZX,0)) S FIRST=0
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" "
;
I $P($G(^ORD(100.05,ZI,8)),"^")="" D Q
.S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Pharmacist Intervention Not Entered"
K DIC,DR,DIQ,DA,INTY S DIC=9009032.4,DA=$P($G(^ORD(100.05,ZI,8)),"^"),DR=".01;.03;.04;.08",DIQ="INTY" D EN^DIQ1
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Intervention Date: "_INTY(9009032.4,DA,.01)
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Provider: "_$S($G(INTY(9009032.4,DA,.03))]"":INTY(9009032.4,DA,.03),1:"Not Entered")
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Pharmacist: "_$S($G(INTY(9009032.4,DA,.04))]"":INTY(9009032.4,DA,.04),1:"Not Entered")
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Recommendation: "_INTY(9009032.4,DA,.08)
K DIC,DR,DIQ,DA,INTY
Q
;
FF ;
W !
S DIR(0)="E",DIR("A")="Press Return to Continue",DIR("?")="Press Return to Redisplay Rx."
D ^DIR S:$D(DUOUT)!($D(DTOUT)) PSOQUIT=1
K DIR,DUOUT,DIRUT,DTOUT,L
W @IOF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODGAL2 11671 printed Dec 13, 2024@02:26:53 Page 2
PSODGAL2 ; BIR/SAB - displays stored DRUG ALLERGY w/sign/symptoms ;10/27/11 02:22
+1 ;;7.0;OUTPATIENT PHARMACY;**390,411**;DEC 1997;Build 95
+2 ;Reference to ^PS(50.605, supported by DBIA 696
+3 ;Reference to GETOC4^OROCAPI1 supported by DBIA 5729
+4 ;Reference to ^ORD(100.05 supported by DBIA 5731
+5 ;Reference to ^GMRD(120.83 supported by DBIA 5767
+6 ;Reference to ^PS(50.416 supported by DBIA 4998
+7 ;
+8 ; This routine is called when the hidden option 'DA' is typed from the OP Medication screen
+9 DO FULL^VALM1
+10 NEW ZORN,X,RET,DA,CNT,ZCNT,ZCNTT,XXI,ZZQ,DA,ZI,ZII,IT,SEVT,SEVN,ZFND,ORCT,ZWARN,DAT,CA,CAG,CLSTAT,PSOASORT,PROSPECT
+11 NEW ZDA,ZDATB,ZST,ZQS,ZALL,ZRX,ZERO,PRTFLG,FLAG2,PSOASEV,PSOREA,PSOTYPE,PSORSITE,PSORDATA,ZIIEN,PSOPROV,PSOCAGNT
+12 NEW PSOQUIT,DIWF,DIWL,DIWR,II,IEN
+13 SET (CNT,FLAG2,ZCNT,ZCNTT,ZFND,PSOQUIT,IEN)=0
+14 IF $GET(PSODGCK)
SET ZRX=PSODGCRX
+15 IF '$GET(PSODGCK)
SET ZRX=$PIECE(PSOLST(ORN),"^",2)
+16 SET ZORN=$PIECE(^PSRX(ZRX,"OR1"),"^",2)
+17 IF 'ZORN
WRITE !,"NO Drug Allergy Order Checks found for Rx#: "_$PIECE(^PSRX(ZRX,0),"^")
GOTO EXT
+18 KILL ^TMP("PSODAOCD",$JOB),^TMP("PSOAL",$JOB)
DO GETOC4^OROCAPI1(ZORN,.RET)
+19 IF $ORDER(RET(ZORN,"DATA",""))=""
SET FLAG2=1
+20 ;
+21 ;
SORT ;build sort by severity, reactant/causitive agent
+1 NEW ZIIEN,ZSIEN,ZSIGNS,SIGN,PSOASEV2,PSOZERO,SIGNS,PSOPTLOC,PSOINST,PSOREA2,PSOREAS,PSOREAB,PSODRGCL,PSODRCL2
+2 NEW DRUGIEN,PSODCLAS,PSJREAB,PSJREAS
+3 FOR ZI=0:0
SET ZI=$ORDER(RET(ZORN,"DATA",ZI))
if 'ZI
QUIT
if +$PIECE(RET(ZORN,"DATA",ZI,1),";",2)=3
Begin DoDot:1
+4 IF $GET(RET(ZORN,"DATA",ZI,"OR",1,0))]""
SET ^TMP("PSODAOCD",$JOB,"AOR",$GET(RET(ZORN,"DATA",ZI,"OR",1,0)))=""
+5 SET ZIIEN=0
FOR
SET ZIIEN=$ORDER(^ORD(100.05,ZI,4,ZIIEN))
if ZIIEN=""
QUIT
IF $DATA(^ORD(100.05,ZI,4,ZIIEN,0))
Begin DoDot:2
+6 if $PIECE(^ORD(100.05,ZI,0),"^",3)["CPRS"
QUIT
+7 SET (PSOZERO,PSOREA,PSOTYPE,PSORSITE,PSOASEV,PSOASEV2,PROSPECT,DRUGIEN,PSJREAB,PSJREAS)=""
+8 SET PSOZERO=$GET(^ORD(100.05,ZI,4,ZIIEN,0))
+9 SET PSOREAB=$PIECE(PSOZERO,"^")
SET PSOREA2=$PIECE($PIECE(PSOZERO,"^",2),";",2)_$PIECE($PIECE(PSOZERO,"^",2),";")
SET PSOASEV=$PIECE(PSOZERO,"^",7)
SET PSOTYPE=$PIECE(PSOZERO,"^",3)
+10 SET PSORSITE=$PIECE(PSOZERO,"^",4)
SET PSOASEV2=$SELECT(PSOASEV=3:"A",PSOASEV="2":"B",PSOASEV=1:"C",1:"D")
+11 IF PSOREAB["/"
Begin DoDot:3
+12 FOR I=1:1
SET PSOREAS=$PIECE(PSOREAB,"/",I)
if PSOREAS=""
QUIT
SET PSOREA=PSOREA_"/ "_PSOREAS
End DoDot:3
SET PSOREA=$EXTRACT(PSOREA,3,$LENGTH(PSOREA))
+13 IF PSOREAB'["/"
SET PSOREA=PSOREAB
+14 ;
+15 ;PROSPECTIVE DRUG/DISPENSED DRUG
+16 IF $DATA(^ORD(100.05,ZI,5,1,0))
SET DRUGIEN=^ORD(100.05,ZI,5,1,0)
+17 ;GENERIC NAME
IF DRUGIEN'=""
SET PROSPECT=$$GET1^DIQ(50,DRUGIEN,.01,"E")
+18 if PROSPECT=""
QUIT
+19 ;
+20 ;DRUG CLASS
+21 SET (PSOCAGNT,PSODRGCL,PSODCLAS,PSODRCL2)=""
+22 FOR ZZQ=0:0
SET ZZQ=$ORDER(^ORD(100.05,ZI,4,ZIIEN,1,ZZQ))
if 'ZZQ!(ZZQ'?1N.N)
QUIT
Begin DoDot:3
+23 SET PSODRCL2=^ORD(100.05,ZI,4,ZIIEN,1,ZZQ,0)
SET PSODCLAS=1
+24 SET PSODRGCL=PSODRGCL_"|"_$$GET1^DIQ(50.605,PSODRCL2,1)
End DoDot:3
+25 IF PSODRGCL'?1A.AP
SET PSODRGCL=$EXTRACT(PSODRGCL,2,999)
+26 if PSODRGCL=""!(PSODRGCL="|")
SET PSODRGCL="aaaa"
+27 SET PSOCAGNT=$SELECT(PSODRGCL'="aaaa":PSODRGCL,1:$PIECE(PSOREA,"|",1))
+28 ;
+29 ;SITES
+30 ;local site
IF PSOTYPE="L"
Begin DoDot:3
+31 SET PSOPTLOC=$PIECE(^PSRX(ZRX,2),"^",9)
SET PSORSITE=$$GET1^DIQ(59,PSOPTLOC,100,"I")
End DoDot:3
+32 SET PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,0)=ZIIEN_"^"_ZI_"^"_PSOCAGNT
+33 IF '$DATA(PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,1))
SET PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,1)=PSOTYPE_"|"_PSORSITE_"|"_$PIECE(PSOZERO,"^",5)
SET ZCNTT=1
+34 IF $DATA(PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,1))
Begin DoDot:3
+35 if PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,1)'[(PSOTYPE_"|"_PSORSITE_"|"_$PIECE(PSOZERO,"^",5))
SET PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,1)=PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,1)_"^"_PSOTYPE_"|"_PSORSITE_"|"_$PIECE(PSOZERO,"^",5)
End DoDot:3
+36 ;
+37 ;SIGNS AND SYMPTOMS
+38 SET ZSIEN=""
FOR
SET ZSIEN=$ORDER(^ORD(100.05,ZI,4,ZIIEN,3,ZSIEN))
if ZSIEN=""
QUIT
IF $DATA(^ORD(100.05,ZI,4,ZIIEN,3,ZSIEN,0))
Begin DoDot:3
+39 SET ZSIGNS=^ORD(100.05,ZI,4,ZIIEN,3,ZSIEN,0)
+40 IF '$DATA(PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,2))
SET PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,2)=ZSIGNS
QUIT
+41 if PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,2)'[("|"_ZSIGNS_"|")
SET PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,2)=PSOASORT(PROSPECT,PSOASEV2,PSOREA,PSOREA2,2)_"|"_ZSIGNS
End DoDot:3
End DoDot:2
End DoDot:1
+42 ;
+43 IF 'ZCNTT
SET FLAG2=1
+44 IF '$GET(PSODGCK)&(FLAG2)
WRITE !,"NO Drug Allergy Order Checks found for Rx#: "_$PIECE(^PSRX(ZRX,0),"^")
GOTO EXT
+45 if FLAG2&($GET(PSODGCK))
QUIT
LOOP ;
+1 ;**** Begin looping through sort
+2 SET (PROSPECT,PSOASEV,PSOREA,PSOREA2,PSOTYPE,PSORSITE,PSORDATA,ZIIEN)=""
+3 FOR
SET PROSPECT=$ORDER(PSOASORT(PROSPECT))
if PROSPECT=""
QUIT
FOR
SET PSOASEV=$ORDER(PSOASORT(PROSPECT,PSOASEV))
if PSOASEV=""
QUIT
Begin DoDot:1
+4 FOR
SET PSOREA=$ORDER(PSOASORT(PROSPECT,PSOASEV,PSOREA))
if PSOREA=""
QUIT
FOR
SET PSOREA2=$ORDER(PSOASORT(PROSPECT,PSOASEV,PSOREA,PSOREA2))
if PSOREA2=""
QUIT
Begin DoDot:2
+5 ;F S ZIIEN=$O(PSOASORT(PROSPECT,PSOASEV,PSOREA,PSOREA2,ZIIEN)) Q:ZIIEN="" D Q:$G(VALMBCK)="R"
+6 SET PSORDATA=PSOASORT(PROSPECT,PSOASEV,PSOREA,PSOREA2,0)
SET (ZIIEN,XXI)=$PIECE(PSORDATA,"^",1)
SET ZI=$PIECE(PSORDATA,"^",2)
+7 SET PSORSITE=PSOASORT(PROSPECT,PSOASEV,PSOREA,PSOREA2,1)
+8 DO ADOC
if $GET(VALMBCK)="R"
QUIT
End DoDot:2
if $GET(VALMBCK)="R"
QUIT
End DoDot:1
if $GET(VALMBCK)="R"
QUIT
+9 ;
PRT ; print allergy information to screen
+1 DO FULL^VALM1
WRITE @IOF
+2 NEW ZZ,PRTFLG
SET PRTFLG=0
+3 WRITE $CHAR(7),!,"A Drug-Allergy Reaction exists for this medication and/or class!",!
+4 SET ZZ=""
FOR
SET ZZ=$ORDER(^TMP("PSOAL",$JOB,ZZ))
if ZZ=""
QUIT
Begin DoDot:1
+5 IF PRTFLG
IF $GET(^TMP("PSOAL",$JOB,ZZ,0))["Prospective Drug:"
DO EXT
WRITE !
+6 WRITE !,^TMP("PSOAL",$JOB,ZZ,0)
SET PRTFLG=1
IF ($Y+2)>IOSL
DO FF
End DoDot:1
if PSOQUIT
GOTO EXIT
+7 ;
+8 KILL DIR,DUOUT,DIRUT,PSOASORT
+9 if PSOQUIT
GOTO EXIT
+10 IF $GET(PRTFLG)
WRITE !
DO FF
+11 GOTO EXIT
+12 QUIT
+13 ;
ADOC ;
+1 NEW ING,SS,DC,OH,CAG,CAUS,SEVT,SEVN,ZALL,Z,ZX,ZALL,FIRST,DRUG,DRUGS,ZCX,PSOWCA,CAUS2,ZLOC,PSOCAR,FLAG,I,ZDATE
+2 NEW SITE,SITET,SITED,I,ZDATA,PSOCSITE
+3 IF XXI'=""
if $PIECE($GET(^ORD(100.05,ZI,4,XXI,0)),"^")]""
Begin DoDot:1
+4 SET (SEVT,SEVN,CAUS,CAUS2,PSOWCA,PSOCAR,OH,DRUG,DRUGS,X,ING,SS,DC,ZALL,ZLOC,ZDATE)=""
+5 SET ZALL=$GET(^ORD(100.05,ZI,4,XXI,0))
SET ZLOC=$PIECE(ZALL,"^",3)
+6 SET CAUS=$PIECE(ZALL,"^",1)
SET CAUS2=$PIECE($PIECE(ZALL,"^",2),";")
+7 SET SEVT=$PIECE(ZALL,"^",7)
SET SEVN=$SELECT(SEVT=1:"MILD",SEVT=2:"MODERATE",SEVT=3:"SEVERE",1:"Not Entered")
+8 SET ^TMP("PSODAOCD",$JOB,"CA",CAUS)=""
+9 ;
+10 ;SITES
+11 SET CAUS=$PIECE(PSOREA," ~")
SET PSOCSITE=""
+12 IF PSORSITE'["^"
Begin DoDot:2
+13 SET ZDATE=$PIECE(PSORSITE,"|",3)
SET ZDATE=$SELECT(ZDATE'="":$EXTRACT(ZDATE,4,5)_"/"_$EXTRACT(ZDATE,6,7)_"/"_$EXTRACT(ZDATE,2,3),1:"")
+14 SET PSOCSITE=$$GET1^DIQ(4,$PIECE(PSORSITE,"|",2),.01,"E")
+15 IF PSOCSITE=""
SET PSOCSITE=$SELECT(PSOCSITE'="":PSOCSITE,ZLOC="L":"LOCAL",ZLOC="R":"REMOTE",1:"Not Given")
+16 SET PSOCAR=CAUS_" ("_PSOCSITE_" - "_ZDATE_")"
End DoDot:2
+17 IF PSORSITE["^"
Begin DoDot:2
+18 FOR I=1:1
SET ZDATA=$PIECE(PSORSITE,"^",I)
if ZDATA=""
QUIT
SET PSOCSITE=""
Begin DoDot:3
+19 SET ZDATE=$PIECE(ZDATA,"|",3)
SET ZDATE=$SELECT(ZDATE'="":$EXTRACT(ZDATE,4,5)_"/"_$EXTRACT(ZDATE,6,7)_"/"_$EXTRACT(ZDATE,2,3),1:"")
+20 SET PSOCSITE=$$GET1^DIQ(4,$PIECE(ZDATA,"|",2),.01,"E")
+21 IF PSOCSITE=""
SET PSOCSITE=$SELECT(PSOCSITE'="":PSOCSITE,ZLOC="L":"LOCAL",ZLOC="R":"REMOTE",1:"Not Given")
+22 SET PSOCAR=PSOCAR_", "_PSOCSITE_" - "_ZDATE
End DoDot:3
End DoDot:2
if PSOCAR'=""
SET PSOCAR=CAUS_" ("_$EXTRACT(PSOCAR,3,999)_")"
+23 ;
+24 ;
+25 IF PSOCAR=""
SET PSOCAR=CAUS
+26 ;OP will only have one drug
+27 ;I $D(^ORD(100.05,ZI,5,1,0)) S DRUGS=^ORD(100.05,ZI,5,1,0) I DRUGS'="" S DRUG=$$GET1^DIQ(50,DRUGS,.01,"E")
+28 ;D GETS^DIQ(100.05,ZI,"50*","E","DRUGS") S:$D(DRUGS(100.06,"1,"_ZI_",",.01,"E")) DRUG=DRUGS(100.06,"1,"_ZI_",",.01,"E")
+29 SET OH=$$UPPER($PIECE(ZALL,"^",6))
SET ^TMP("PSODAOCD",$JOB,"OH")=OH
+30 SET IEN=$GET(IEN)+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Prospective Drug: "_PROSPECT
SET PRTFLG=1
+31 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=58
SET DIWF=""
+32 SET X=PSOCAR
+33 DO ^DIWP
SET FIRST=1
+34 FOR ZCX=0:0
SET ZCX=$ORDER(^UTILITY($JOB,"W",1,ZCX))
if 'ZCX
QUIT
if $DATA(^UTILITY($JOB,"W",1,ZCX,0))
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=$SELECT(FIRST:" Causative Agent: "_^UTILITY($JOB,"W",1,ZCX,0),1:" "_^UTILITY($JOB,"W",1,ZCX,0))
SET FIRST=0
+35 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)="Historical/Observed: "_$SELECT(OH="H":"HISTORICAL",OH="O":"OBSERVED",1:"Not Entered")
+36 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Severity: "_$GET(SEVN)
+37 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=58
SET DIWF=""
+38 ;
+39 ; DRUG INGREDIENT
+40 SET FLAG=0
+41 KILL ^TMP("PSODAOCD",$JOB,"DI")
+42 FOR ZZQ=0:0
SET ZZQ=$ORDER(^ORD(100.05,ZI,4,XXI,2,ZZQ))
if 'ZZQ
QUIT
SET ^TMP("PSODAOCD",$JOB,"DI",$PIECE(^PS(50.416,$PIECE(^ORD(100.05,ZI,4,XXI,2,ZZQ,0),"^"),0),"^"))=""
SET FLAG=1
+43 SET X=""
+44 FOR
SET ING=$ORDER(^TMP("PSODAOCD",$JOB,"DI",ING))
if ING=""
QUIT
SET X=X_", "_ING
+45 SET X=$EXTRACT(X,3,999)
+46 IF X'=""
Begin DoDot:2
+47 DO ^DIWP
+48 SET FIRST=1
+49 FOR ZX=0:0
SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
if 'ZX
QUIT
if $DATA(^UTILITY($JOB,"W",1,ZX,0))
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=$SELECT(FIRST:" Ingredients: "_^UTILITY($JOB,"W",1,ZX,0),1:" "_^UTILITY($JOB,"W",1,ZX,0))
SET FIRST=0
End DoDot:2
+50 ;
+51 ; SIGNS/SYMPTOMS
+52 KILL ^UTILITY($JOB,"W"),^TMP("PSODAOCD",$JOB,"SS")
SET DIWL=1
SET DIWR=58
SET DIWF=""
SET ING=""
+53 SET (X,SIGNS,SIGN)=""
SET SIGNS=$GET(PSOASORT(PROSPECT,PSOASEV,PSOREA,PSOREA2,2))
+54 IF SIGNS'=""
FOR ZZQ=1:1
SET SIGN=$PIECE(SIGNS,"|",ZZQ)
if SIGN=""
QUIT
Begin DoDot:2
+55 IF $GET(^GMRD(120.83,SIGN,0))]""
SET ^TMP("PSODAOCD",$JOB,"SS",$PIECE(^GMRD(120.83,SIGN,0),"^"))=""
End DoDot:2
+56 SET X=""
SET FIRST=1
+57 IF $ORDER(^TMP("PSODAOCD",$JOB,"SS",""))]""
SET SS=""
Begin DoDot:2
+58 FOR
SET SS=$ORDER(^TMP("PSODAOCD",$JOB,"SS",SS))
if SS=""
QUIT
SET X=X_", "_SS
End DoDot:2
+59 SET X=$EXTRACT(X,3,999)
if X=""
SET X="None Entered"
DO ^DIWP
+60 FOR ZX=0:0
SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
if 'ZX
QUIT
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=$SELECT(FIRST:" Signs/Symptoms: "_^UTILITY($JOB,"W",1,ZX,0),1:" "_^UTILITY($JOB,"W",1,ZX,0))
SET FIRST=0
+61 KILL ^UTILITY($JOB,"W")
+62 ;
+63 ; DRUG CLASS
+64 SET DIWL=1
SET DIWR=58
SET DIWF=""
KILL ^TMP("PSODAOCD",$JOB,"DC")
+65 FOR ZZQ=0:0
SET ZZQ=$ORDER(^ORD(100.05,ZI,4,XXI,1,ZZQ))
if 'ZZQ
QUIT
SET ^TMP("PSODAOCD",$JOB,"DC",$PIECE(^ORD(100.05,ZI,4,XXI,1,ZZQ,0),"^"))=$PIECE(^PS(50.605,$PIECE(^ORD(100.05,ZI,4,XXI,1,ZZQ,0),"^"),0),"^")_" "_$PIECE(^(0),"^",2)
+66 SET X=""
SET FIRST=1
+67 FOR DC=0:0
SET DC=$ORDER(^TMP("PSODAOCD",$JOB,"DC",DC))
if 'DC
QUIT
SET X=X_", "_^TMP("PSODAOCD",$JOB,"DC",DC)
Begin DoDot:2
+68 IF $LENGTH(X)>234
SET X=$EXTRACT(X,3,999)
DO ^DIWP
SET X=""
End DoDot:2
+69 IF X'=""
SET X=$EXTRACT(X,3,999)
+70 IF X'=""
Begin DoDot:2
+71 DO ^DIWP
+72 FOR ZX=0:0
SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
if 'ZX
QUIT
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=$SELECT(FIRST:" Drug Class: "_^UTILITY($JOB,"W",1,ZX,0),1:" "_^UTILITY($JOB,"W",1,ZX,0))
SET FIRST=0
+73 KILL ^UTILITY($JOB,"W")
NEW Z,ZX
End DoDot:2
End DoDot:1
+74 ;
+75 ; intervention
DO INV
+76 QUIT
+77 ;
UPPER(PSOUCS) ;
+1 QUIT $TRANSLATE(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
LOWER(PSOLCS) ;
+1 QUIT $TRANSLATE(PSOLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
+2 ;
EXT ;
+1 KILL DIR,DUOUT,DIRUT,ZFND
+2 DO FF
+3 IF $DATA(DIRUT)
GOTO EXIT
+4 QUIT
EXIT ;
+1 SET VALMBCK="R"
KILL DIR,DUOUT,DIRUT,ZFND,^TMP("PSODAOCD",$JOB),^TMP("PSOAL",$JOB),ZPGK
+2 QUIT
+3 ;
INV ;display intervention
+1 ;changed to add Provider & Pharmacist and put in correct sequence [ST - 6.17.2014]
+2 SET IEN=$GET(IEN)+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" "
+3 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=55
SET DIWF=""
+4 SET PSOPROV=""
SET PSOPROV="N/A - Order Check Not Evaluated by Provider"
+5 IF $ORDER(^TMP("PSODAOCD",$JOB,"AOR",""))]""
SET PSOPROV=$ORDER(^TMP("PSODAOCD",$JOB,"AOR",""))
+6 SET X=PSOPROV
SET FIRST=1
DO ^DIWP
+7 FOR ZX=0:0
SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
if 'ZX
QUIT
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=$SELECT(FIRST:"Provider Override Reason: "_^UTILITY($JOB,"W",1,ZX,0),1:" "_^UTILITY($JOB,"W",1,ZX,0))
SET FIRST=0
+8 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" "
+9 ;
+10 IF $PIECE($GET(^ORD(100.05,ZI,8)),"^")=""
Begin DoDot:1
+11 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)="Pharmacist Intervention Not Entered"
End DoDot:1
QUIT
+12 KILL DIC,DR,DIQ,DA,INTY
SET DIC=9009032.4
SET DA=$PIECE($GET(^ORD(100.05,ZI,8)),"^")
SET DR=".01;.03;.04;.08"
SET DIQ="INTY"
DO EN^DIQ1
+13 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)="Intervention Date: "_INTY(9009032.4,DA,.01)
+14 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Provider: "_$SELECT($GET(INTY(9009032.4,DA,.03))]"":INTY(9009032.4,DA,.03),1:"Not Entered")
+15 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Pharmacist: "_$SELECT($GET(INTY(9009032.4,DA,.04))]"":INTY(9009032.4,DA,.04),1:"Not Entered")
+16 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Recommendation: "_INTY(9009032.4,DA,.08)
+17 KILL DIC,DR,DIQ,DA,INTY
+18 QUIT
+19 ;
FF ;
+1 WRITE !
+2 SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
SET DIR("?")="Press Return to Redisplay Rx."
+3 DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
SET PSOQUIT=1
+4 KILL DIR,DUOUT,DIRUT,DTOUT,L
+5 WRITE @IOF
+6 QUIT
