PSJDGAL2 ;BIR/SAB - displays stored DRUG ALLERGY w/sign/symptoms ;10/27/11 02:22
;;5.0;INPATIENT MEDICATIONS;**260,281**;16 DEC 97;Build 113
;External reference to ^PS(50.605, supported by DBIA 696
;External reference to GETOC4^OROCAPI1 supported by DBIA 5729
;External reference to ^ORD(100.05 supported by DBIA 5731
;External reference to ^GMRD(120.83 supported by DBIA 5767
;External reference to ^PS(55 supported by DBIA 2191
;External reference to ^PS(50.416 supported by DBIA 4998
;External Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
;
START ; This routine is called when the hidden option 'DA' is typed from the IP Medication screen
N PSJNOALL
; If allergy is not stored in 100.05 then don't allow DA at that point.
I $D(^TMP("PSODAOC",$J,"ALLERGY")) W !,"DA is not a valid selection." H 1 Q
I +$G(PSJAGYSV),$D(^TMP("PSODAOC",$J)) W !,"DA is not a valid selection." H 1 Q
I '$G(PSJORD) W !!,"NO Drug Allergy Order Checks found." S PSJNOALL=1 G EXT
N ZORN,X,RET,DA,ZCNT,ZCNTT,XXI,ZZQ,DA,ZI,IT,SEVT,SEVN,ZFND,ZDA,ZDATB,ZST,ZQS,ZDATE,ZERO,PSJPROV,PSJDGORD,PSJDALOC
N FLAG2,PRTFLG,PSJASORT,PSJQUIT,PSJZERO,PSJREA,PSJTYPE,PSJRSITE,PSJASEV,PSJASEV2,PSJRDATA,ZIIEN,DIE,DIR,DR,DIC
N PSJQUIT,DIWF,DIWL,DIWR,II,PSJTSTMD,IEN,PSJSSITE,PSJDAOC,PSJDRGCL,PSJCAGNT,PSJDATA,PROSPECT,PSJDOI,PSJDOIN,PSJOIN
S (FLAG2,ZCNT,ZCNTT,ZFND,PSJQUIT,IEN,PSJDGORD)=0
D FULL^VALM1
;gets drug allergy order chks PSJ*5*260
D
.; -- RTC 187974 - remove check for variable - !($G(PSJDSVFY))
.I $G(PSIVCOPY) S PSJDGORD=$S($G(ON)["P":ON,$G(ON55)["P":ON55,1:"") S:$G(PSJDGORD) ZORN=+$P(^PS(53.1,+PSJDGORD,0),U,21),PSJDALOC=+PSJDGORD_"P" Q
.I $G(PSJORD)["P" S PSJDGORD=$G(PSJORD) S:$G(PSJDGORD) ZORN=+$P(^PS(53.1,+PSJDGORD,0),U,21),PSJDALOC=+PSJDGORD_"P" Q
.I $G(PSJORD)["U" S PSJDGORD=$G(PSJORD) S:$G(PSJDGORD) ZORN=+$P(^PS(55,DFN,5,+PSJDGORD,0),U,21),PSJDALOC=DFN_"U"_+PSJDGORD Q
.I $G(PSJORD)["V" S PSJDGORD=$G(PSJORD) S:$G(PSJDGORD) ZORN=+$P(^PS(55,DFN,"IV",+PSJDGORD,0),U,21),PSJDALOC=DFN_"V"_+PSJDGORD
.Q:+$G(ZORN)
.I $G(ON)["P"!($G(ON55)["P") S PSJDGORD=$S($G(ON)["P":ON,$G(ON55)["P":ON55,1:"") S ZORN=+$P(^PS(53.1,+PSJDGORD,0),U,21),PSJDALOC=+PSJDGORD_"P" Q
.I $G(ON)["U"!($G(ON55)["U") S PSJDGORD=$S($G(ON)["U":ON,$G(ON55)["U":ON55,1:"") S ZORN=+$P(^PS(55,DFN,5,+PSJDGORD,0),U,21),PSJDALOC=DFN_"U"_+PSJDGORD Q
.I $G(ON)["V"!($G(ON55)["V") S PSJDGORD=$S($G(ON)["V":ON,$G(ON55)["V":ON55,1:"") S ZORN=+$P(^PS(55,DFN,"IV",+PSJDGORD,0),U,21),PSJDALOC=DFN_"V"_+PSJDGORD
;
S:'$D(PSJDAOC) PSJDAOC="IP"
I '$G(ZORN) W !!,"NO Drug Allergy Order Checks found." G EXT
D SET3^PSJNEWOC ;set up variables for order check
S PSJDAOC=$G(PSJDAOC)_"Allergy"
I $L(PSJDAOC)>40 S PSJDAOC=$E(PSJDAOC,1,40)
K ^TMP("PSJDAOCD",$J),^TMP("PSJAL",$J),RET S RET=""
D GETOC4^OROCAPI1(ZORN,.RET)
I $O(RET(ZORN,"DATA",""))="" S FLAG2=1
;
F ZI=0:0 S ZI=$O(RET(ZORN,"DATA",ZI)) Q:'ZI I +$P(RET(ZORN,"DATA",ZI,1),";",2)=3 S ZCNTT=1
I 'ZCNTT S FLAG2=1 W !!,"NO Drug Allergy Order Checks found." S PSJNOALL=1 G EXT
;
SORT ;build sort by severity, reactant/causitive agent
K PSJASORT
N ZIIEN,ZSIEN,ZSIGNS,SIGN,SIGNS,PSJPTLOC,PSJINST,PSJDCLAS,PSJIEN70,PSJIEN60,PSJDFLAG,PSJRETI,PSJAIENS,PSJDRCL2
N PSJFROM1,PSJREAB,PSJREAS,I
F ZI=0:0 S ZI=$O(RET(ZORN,"DATA",ZI)) Q:'ZI I $D(RET(ZORN,"DATA",ZI,1)) D
.Q:+$P(RET(ZORN,"DATA",ZI,1),";",2)'=3
.I $G(RET(ZORN,"DATA",ZI,"OR",1,0))]"" S ^TMP("PSJDAOCD",$J,"AOR",$G(RET(ZORN,"DATA",ZI,"OR",1,0)))=""
.K PSJAIENS
.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 (PSJZERO,PSJREAB,PSJREA,PSJREAS,PSJTYPE,PSJRSITE,PSJSSITE,PSJASEV,PSJASEV2,PSJDRGCL,PSJIEN70,PSJIEN60,PSJDFLAG,PSJRETI,PSJFROM1)=""
..;
..D GETS^DIQ(100.05,ZI,"70*","I","PSJIEN70"),GETS^DIQ(100.05,ZI,"60*","I","PSJIEN60")
..S PSJDFLAG="",PSJDFLAG=$$GETORD^PSJNEWOA(ZI,PSJDGORD,PSJDFLAG)
..Q:'PSJDFLAG
..;
..S PSJZERO=$G(^ORD(100.05,ZI,4,ZIIEN,0))
..S PSJREAB=$P(PSJZERO,"^"),PSJFROM1=$P(PSJZERO,"^",2),PSJASEV=$P(PSJZERO,"^",7),PSJTYPE=$P(PSJZERO,"^",3)
..S PSJRSITE=$P(PSJZERO,"^",4),PSJASEV2=$S(PSJASEV=3:"A",PSJASEV="2":"B",PSJASEV=1:"C",1:"D")
..I PSJREAB["/" D S PSJREA=$E(PSJREA,3,$L(PSJREA))
...F I=1:1 S PSJREAS=$P(PSJREAB,"/",I) Q:PSJREAS="" S PSJREA=PSJREA_"/ "_PSJREAS
..I PSJREAB'["/" S PSJREA=PSJREAB
..;DRUG CLASS
..S (PSJCAGNT,PSJDRGCL,PSJDCLAS,PSJDRCL2)=""
..F ZZQ=0:0 S ZZQ=$O(^ORD(100.05,ZI,4,ZIIEN,1,ZZQ)) Q:'ZZQ!(ZZQ'?1N.N) D
...S PSJDRCL2=^ORD(100.05,ZI,4,ZIIEN,1,ZZQ,0),PSJDCLAS=1
...S PSJDRGCL=PSJDRGCL_"|"_$$GET1^DIQ(50.605,PSJDRCL2,1)
..I PSJDRGCL'?1A.AP S PSJDRGCL=$E(PSJDRGCL,2,999)
..S:PSJDRGCL=""!(PSJDRGCL="|") PSJDRGCL="aaaa"
..S PSJCAGNT=$S(PSJDRGCL'="aaaa":PSJDRGCL,1:$P(PSJREA,"|",1))
..S (PSJDOI,PSJDOIN,PROSPECT,DRUGIEN)=""
..;
..I $D(^ORD(100.05,ZI,5,1,0)) S DRUGIEN=^ORD(100.05,ZI,5,1,0)
..I DRUGIEN'="" D
...S DRUG=$$GET1^DIQ(50,DRUGIEN,.01,"E"),PSJOIN=$$GET1^DIQ(50,DRUGIEN,2.1,"E")
...S PROSPECT=DRUG ;GENERIC NAME
...I $G(PSJDGORD)["V"!($G(PSJDGORD)["P")&($D(^PS(53.1,+$G(PSJDGORD),"AD"))) S PROSPECT=PSJOIN ;orderable item if IV
..Q:PROSPECT=""
..I PSJTYPE="L" S PSJRSITE=$$INST^PSJGMRA($G(PSJDALOC))
..;
..I $D(PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,0)) D
...S:PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,0)'[(ZIIEN_"^"_ZI) PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,0)=PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,0)_"|"_ZIIEN_"^"_ZI_"^"_PSJCAGNT
..I '$D(PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,0)) S PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,0)=ZIIEN_"^"_ZI_"^"_PSJCAGNT
..S PSJDATA="",PSJDATA=PSJTYPE_"|"_PSJRSITE_"|"_$P(PSJZERO,"^",5)
..I $D(PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,1)) D
...S:PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,1)'[PSJDATA PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,1)=PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,1)_"^"_PSJDATA
..I '$D(PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,1)) S PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,1)=PSJDATA,FLAG2=1
..;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(PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,2)) S PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,2)=ZSIGNS Q
...S:PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,2)'[("|"_ZSIGNS_"|") PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,2)=PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,2)_"|"_ZSIGNS
;
I 'FLAG2 W !!,"NO Drug Allergy Order Checks found." S PSJNOALL=1 G EXT
;
LOOP ;
;**** Begin looping through sort
S (PSJASEV,PSJREA,PSJTYPE,ZIIEN,PROSPECT,PSJDRGCL,PSJCAGNT,PSJFROM1)=""
F S PROSPECT=$O(PSJASORT(PROSPECT)) Q:PROSPECT="" D
.S IEN=$G(IEN)+1,^TMP("PSJAL",$J,IEN,0)="A Drug-Allergy Reaction exists for this medication and/or class!"
.S IEN=$G(IEN)+1,^TMP("PSJAL",$J,IEN,0)=" "
.F S PSJASEV=$O(PSJASORT(PROSPECT,PSJASEV)) Q:PSJASEV="" D
..F S PSJCAGNT=$O(PSJASORT(PROSPECT,PSJASEV,PSJCAGNT)) Q:PSJCAGNT="" d
...F S PSJFROM1=$O(PSJASORT(PROSPECT,PSJASEV,PSJCAGNT,PSJFROM1)) Q:PSJFROM1="" D ADOC
;
PRT ; print allergy information to screen
D FULL^VALM1 W @IOF
N ZZ,PRTFLG,PRTFLG3 S (PRTFLG3,PRTFLG)=0
W $C(7),!
S ZZ="" F S ZZ=$O(^TMP("PSJAL",$J,ZZ)) Q:ZZ="" D G EXIT:PSJQUIT
.S PSJDATA="",PSJDATA=$G(^TMP("PSJAL",$J,ZZ,0))
.I PRTFLG D
..I PSJDATA["A Drug-Allergy Reaction exists for this medication and/or class" D EXT S (PRTFLG3,PRTFLG)=0
.I PSJDATA["Prospective Drug" S PRTFLG3=PRTFLG3+1
.I PRTFLG,PRTFLG3>1,PSJDATA["Prospective Drug" D EXT W !
.W !,PSJDATA S PRTFLG=1 I ($Y+3)>IOSL D FF
;
K DIR,DUOUT,DIRUT
G EXIT:PSJQUIT
I $G(PRTFLG) W ! D FF
G EXIT
Q
;
ADOC ;
N ING,SS,DC,OH,CAG,CAUS,SEVT,SEVN,ZALL,Z,ZX,ZALL,FIRST,DRUGIEN,DRUG,DRUGS,ZCX,PSJWCA,CAUS2,CAUS3,ZLOC,PSJCAR,FLAG,I,ZDATE
N SITE,SITET,SITED,I,ZDATA,PSJSITE,PSJCSITE,CAUS4,PSJRDAT2,PSJNCOM,PSJNCOM1,PSJCOI,PSJCU,PSJCDF,PSJCPROS
S (PSJRSITE,PSJRDATA)=""
S PSJRDATA=PSJASORT(PROSPECT,PSJASEV,PSJCAGNT,PSJFROM1,0)
;RTC 190465 - DA not display when allergy contains 2 or more VA Classes
;F I=1:1 S PSJRDAT2=$P(PSJRDATA,"|",I) Q:PSJRDAT2=""
;S:(I-1)>0 XXI=$P(PSJRDATA,"|",I-1)
;S ZI=$P(XXI,"^",2),XXI=+XXI
S ZI=$P(PSJRDATA,"^",2),XXI=+PSJRDATA
S PSJRSITE=PSJASORT(PROSPECT,PSJASEV,PSJCAGNT,PSJFROM1,1)
;
Q:XXI'>0
Q:'+ZI
Q:$P($G(^ORD(100.05,ZI,4,XXI,0)),"^")']""
S (SEVT,SEVN,CAUS,CAUS3,CAUS2,CAUS4,PSJWCA,PSJCAR,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),";"),CAUS3=$$GET1^DIQ(50.6,CAUS2,.01,"E")
S SEVT=$P(ZALL,"^",7),SEVN=$S(SEVT=1:"MILD",SEVT=2:"MODERATE",SEVT=3:"SEVERE",1:"Not Entered")
S ^TMP("PSJDAOCD",$J,"CA",CAUS)=""
S CAUS=PSJCAGNT,PSJCSITE=""
;**** PARSE OUT SITES
I CAUS'?1A.AP S CAUS=$P(ZALL,"^",1)
I PSJRSITE'["^" D
.S ZDATE=$P(PSJRSITE,"|",3),ZDATE=$S(ZDATE'="":$E(ZDATE,4,5)_"/"_$E(ZDATE,6,7)_"/"_$E(ZDATE,2,3),1:"")
.S PSJCSITE=$P(PSJRSITE,"|",2),PSJCSITE=$$GET1^DIQ(4,PSJCSITE,.01)
.S PSJCSITE=$S(PSJCSITE'="":PSJCSITE,ZLOC="L":"LOCAL",ZLOC="R":"REMOTE",1:"Not Given")
.S PSJCAR=CAUS_" ("_PSJCSITE_" - "_ZDATE_")"
I PSJRSITE["^" D S:PSJCAR'="" PSJCAR=CAUS_" ("_$E(PSJCAR,3,999)_")"
.F I=1:1 S ZDATA=$P(PSJRSITE,"^",I) Q:ZDATA="" S PSJCSITE="" D
..S ZDATE=$P(ZDATA,"|",3),ZDATE=$S(ZDATE'="":$E(ZDATE,4,5)_"/"_$E(ZDATE,6,7)_"/"_$E(ZDATE,2,3),1:"")
..S PSJCSITE=$P(ZDATA,"|",2),PSJCSITE=$$GET1^DIQ(4,PSJCSITE,.01)
..S PSJCSITE=$S(PSJCSITE'="":PSJCSITE,ZLOC="L":"LOCAL",ZLOC="R":"REMOTE",1:"Not Given")
..S PSJCAR=PSJCAR_", "_PSJCSITE_" - "_ZDATE
;****
I PSJCAR="" S PSJCAR=CAUS
S (PSJNCOM1,PSJCPROS)="" S PSJNCOM1=$$FINDC($G(PSJORD)) S:+$G(PSJNCOM1) PSJCPROS=$P(PSJNCOM1,"^",2),PSJNCOM1=$P(PSJNCOM1,"^")
S IEN=$G(IEN)+1,^TMP("PSJAL",$J,IEN,0)=" Prospective Drug: "_$S($G(PSJNCOM1):PSJCPROS,1:PROSPECT)
S OH=$$UPPER($P(ZALL,"^",6)),^TMP("PSJDAOCD",$J,"OH")=OH
K ^UTILITY($J,"W") S DIWL=1,DIWR=58,DIWF=""
S X=PSJCAR
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=$G(IEN)+1,^TMP("PSJAL",$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("PSJAL",$J,IEN,0)="Historical/Observed: "_$S(OH="H":"HISTORICAL",OH="O":"OBSERVED",1:"Not Entered")
S IEN=IEN+1,^TMP("PSJAL",$J,IEN,0)=" Severity: "_$G(SEVN)
K ^UTILITY($J,"W") S DIWL=1,DIWR=58,DIWF=""
INGRED ;
; DRUG INGREDIENT
S FLAG=0 K ^TMP("PSJDAOCD",$J,"DI") N PSJDRCL3
F ZZQ=0:0 S ZZQ=$O(^ORD(100.05,ZI,4,XXI,2,ZZQ)) Q:'ZZQ S ^TMP("PSJDAOCD",$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("PSJDAOCD",$J,"DI",ING)) Q:ING="" S X=X_", "_ING
S X=$E(X,3,999)
;S X=$P(ZALL,"^",1)
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("PSJAL",$J,IEN,0)=$S(FIRST:" Ingredients: "_^UTILITY($J,"W",1,ZX,0),1:" "_^UTILITY($J,"W",1,ZX,0)) S FIRST=0
SIGNS ;
; SIGNS/SYMPTOMS
K ^UTILITY($J,"W"),^TMP("PSJDAOCD",$J,"SS") S DIWL=1,DIWR=58,DIWF="",ING=""
S (X,SIGNS,SIGN)="",SIGNS=$G(PSJASORT(PROSPECT,PSJASEV,PSJCAGNT,PSJFROM1,2))
I SIGNS'="" F ZZQ=1:1 S SIGN=$P(SIGNS,"|",ZZQ) Q:SIGN="" D
.I $G(^GMRD(120.83,SIGN,0))]"" S ^TMP("PSJDAOCD",$J,"SS",$P(^GMRD(120.83,SIGN,0),"^"))=""
S X="",FIRST=1
I $O(^TMP("PSJDAOCD",$J,"SS",""))]"" S SS="" D
.F S SS=$O(^TMP("PSJDAOCD",$J,"SS",SS)) Q:SS="" S X=X_", "_SS
S X=$E(X,3,999) D ^DIWP
F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX S IEN=IEN+1,^TMP("PSJAL",$J,IEN,0)=$S(FIRST:" Signs/Symptoms: "_$S(SIGNS="":"None Entered",1:^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("PSJDAOCD",$J,"DC")
F ZZQ=0:0 S ZZQ=$O(^ORD(100.05,ZI,4,XXI,1,ZZQ)) Q:'ZZQ D
.S PSJDRCL3="",PSJDRCL3=$P(^PS(50.605,+$P(^ORD(100.05,ZI,4,XXI,1,ZZQ,0),"^"),0),"^") S ^TMP("PSJDAOCD",$J,"DC",+$P(^ORD(100.05,ZI,4,XXI,1,ZZQ,0),"^"))=PSJDRCL3_" "_$P($G(^PS(50.605,+$P($G(^ORD(100.05,ZI,4,XXI,1,ZZQ,0)),"^"),0)),"^",2)
S X="",FIRST=1
F DC=0:0 S DC=$O(^TMP("PSJDAOCD",$J,"DC",DC)) Q:'DC S X=X_", "_^TMP("PSJDAOCD",$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("PSJAL",$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(PSJUCS) ;
Q $TR(PSJUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
LOWER(PSJLCS) ;
Q $TR(PSJLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
;
EXT ;
K DIR,DUOUT,DIRUT,ZFND
I $G(PSJNOALL) D FULL^VALM1,PAUSE^VALM1 S VALMBCK="R" K PSJQUIT,DIR,DUOUT,DIRUT Q
D FF
I $D(DIRUT) G EXIT
Q
EXIT ;
I $G(PSJNOALL) D FULL^VALM1,PAUSE^VALM1 K PSJQUIT
S VALMBCK="R" K DIR,DUOUT,DIRUT,^TMP("PSJDAOCD",$J),^TMP("PSJAL",$J),ZPGK
Q
;
INV ;display intervention
;changed to add Provider & Pharmacist and put in current sequence [ST - 6.17.2014]
S IEN=$G(IEN)+1,^TMP("PSJAL",$J,IEN,0)=" "
K ^UTILITY($J,"W") S DIWL=1,DIWR=55,DIWF=""
S PSJPROV="",PSJPROV="N/A - Order Check Not Evaluated by Provider"
I $O(^TMP("PSJDAOCD",$J,"AOR",""))]"" S PSJPROV=$O(^TMP("PSJDAOCD",$J,"AOR",""))
S X=PSJPROV,FIRST=1 D ^DIWP
F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX S IEN=IEN+1,^TMP("PSJAL",$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=$G(IEN)+1,^TMP("PSJAL",$J,IEN,0)=" "
;
I $P($G(^ORD(100.05,ZI,8)),"^")="" D Q
.S IEN=IEN+1,^TMP("PSJAL",$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("PSJAL",$J,IEN,0)="Intervention Date: "_INTY(9009032.4,DA,.01)
S IEN=IEN+1,^TMP("PSJAL",$J,IEN,0)=" Provider: "_$S($G(INTY(9009032.4,DA,.03))]"":INTY(9009032.4,DA,.03),1:"Not Entered")
S IEN=IEN+1,^TMP("PSJAL",$J,IEN,0)=" Pharmacist: "_$S($G(INTY(9009032.4,DA,.04))]"":INTY(9009032.4,DA,.04),1:"Not Entered")
S IEN=IEN+1,^TMP("PSJAL",$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)) PSJQUIT=1
K DIR,DUOUT,DIRUT,DTOUT,L
W @IOF
Q
;
FINDC(PSJORD) ;determine if order is part of a complex UD order
;for complex UD orders display format: orderable item doseform (units) ex: MORPHINE TAB,SA (100MG)
Q:PSJORD=""
N PSJCOMD,PSJCOI,PSJCU,PSJCDF,PSJCPROS
S (PSJCOMD,PSJCOI,PSJCU,PSJCDF,PSJCPROS,PSJNCOM)=""
I $G(PSJORD)["P"!($G(PSJORD)["N") D FINDCP
E D FINDCA
Q PSJNCOM_"^"_PSJCPROS
;
FINDCP ;COMPLEX PENDING ORDER
S PSJNCOM=+$P($G(^PS(53.1,+PSJORD,.2)),"^",8)
I $G(PSJNCOM) D
.D GETS^DIQ(53.1,+PSJORD,"108;109","EI","PSJCOMD")
.S PSJCU=PSJCOMD(53.1,+PSJORD_",",109,"E"),PSJCOI=PSJCOMD(53.1,+PSJORD_",",108,"E")
.I PSJCOI'="" S PSJCDF=$$GET1^DIQ(50.7,$G(PSJCOMD(53.1,+PSJORD_",",108,"I")),.02,"E")
.S PSJCPROS=$S(PSJCOI'="":PSJCOI_" "_PSJCDF_" ("_PSJCU_")",1:PROSPECT)
Q
;
FINDCA ;COMPLEX ACTIVE ORDER
N PSJCPRSO S PSJCPRSO="",PSJCPRSO=$$GET1^DIQ(55.06,+PSJORD_","_DFN_",",125,"I")
Q:PSJCPRSO=""
I $D(^PS(55,"ACX",PSJCPRSO)) S PSJNCOM=1 D
.D GETS^DIQ(55.06,+PSJORD_","_DFN_",","108;109","IE","PSJCOMD")
.S PSJCOI=$G(PSJCOMD(55.06,+PSJORD_","_DFN_",",108,"E")),PSJCU=$G(PSJCOMD(55.06,+PSJORD_","_DFN_",",109,"E"))
.I PSJCOI'="" S PSJCDF=$$GET1^DIQ(50.7,$G(PSJCOMD(55.06,+PSJORD_",742,",108,"I")),.02,"E")
.S PSJCPROS=$S(PSJCOI'="":PSJCOI_" "_PSJCDF_" ("_PSJCU_")",1:PROSPECT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJDGAL2 16097 printed Dec 13, 2024@02:06:40 Page 2
PSJDGAL2 ;BIR/SAB - displays stored DRUG ALLERGY w/sign/symptoms ;10/27/11 02:22
+1 ;;5.0;INPATIENT MEDICATIONS;**260,281**;16 DEC 97;Build 113
+2 ;External reference to ^PS(50.605, supported by DBIA 696
+3 ;External reference to GETOC4^OROCAPI1 supported by DBIA 5729
+4 ;External reference to ^ORD(100.05 supported by DBIA 5731
+5 ;External reference to ^GMRD(120.83 supported by DBIA 5767
+6 ;External reference to ^PS(55 supported by DBIA 2191
+7 ;External reference to ^PS(50.416 supported by DBIA 4998
+8 ;External Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
+9 ;
START ; This routine is called when the hidden option 'DA' is typed from the IP Medication screen
+1 NEW PSJNOALL
+2 ; If allergy is not stored in 100.05 then don't allow DA at that point.
+3 IF $DATA(^TMP("PSODAOC",$JOB,"ALLERGY"))
WRITE !,"DA is not a valid selection."
HANG 1
QUIT
+4 IF +$GET(PSJAGYSV)
IF $DATA(^TMP("PSODAOC",$JOB))
WRITE !,"DA is not a valid selection."
HANG 1
QUIT
+5 IF '$GET(PSJORD)
WRITE !!,"NO Drug Allergy Order Checks found."
SET PSJNOALL=1
GOTO EXT
+6 NEW ZORN,X,RET,DA,ZCNT,ZCNTT,XXI,ZZQ,DA,ZI,IT,SEVT,SEVN,ZFND,ZDA,ZDATB,ZST,ZQS,ZDATE,ZERO,PSJPROV,PSJDGORD,PSJDALOC
+7 NEW FLAG2,PRTFLG,PSJASORT,PSJQUIT,PSJZERO,PSJREA,PSJTYPE,PSJRSITE,PSJASEV,PSJASEV2,PSJRDATA,ZIIEN,DIE,DIR,DR,DIC
+8 NEW PSJQUIT,DIWF,DIWL,DIWR,II,PSJTSTMD,IEN,PSJSSITE,PSJDAOC,PSJDRGCL,PSJCAGNT,PSJDATA,PROSPECT,PSJDOI,PSJDOIN,PSJOIN
+9 SET (FLAG2,ZCNT,ZCNTT,ZFND,PSJQUIT,IEN,PSJDGORD)=0
+10 DO FULL^VALM1
+11 ;gets drug allergy order chks PSJ*5*260
+12 Begin DoDot:1
+13 ; -- RTC 187974 - remove check for variable - !($G(PSJDSVFY))
+14 IF $GET(PSIVCOPY)
SET PSJDGORD=$SELECT($GET(ON)["P":ON,$GET(ON55)["P":ON55,1:"")
if $GET(PSJDGORD)
SET ZORN=+$PIECE(^PS(53.1,+PSJDGORD,0),U,21)
SET PSJDALOC=+PSJDGORD_"P"
QUIT
+15 IF $GET(PSJORD)["P"
SET PSJDGORD=$GET(PSJORD)
if $GET(PSJDGORD)
SET ZORN=+$PIECE(^PS(53.1,+PSJDGORD,0),U,21)
SET PSJDALOC=+PSJDGORD_"P"
QUIT
+16 IF $GET(PSJORD)["U"
SET PSJDGORD=$GET(PSJORD)
if $GET(PSJDGORD)
SET ZORN=+$PIECE(^PS(55,DFN,5,+PSJDGORD,0),U,21)
SET PSJDALOC=DFN_"U"_+PSJDGORD
QUIT
+17 IF $GET(PSJORD)["V"
SET PSJDGORD=$GET(PSJORD)
if $GET(PSJDGORD)
SET ZORN=+$PIECE(^PS(55,DFN,"IV",+PSJDGORD,0),U,21)
SET PSJDALOC=DFN_"V"_+PSJDGORD
+18 if +$GET(ZORN)
QUIT
+19 IF $GET(ON)["P"!($GET(ON55)["P")
SET PSJDGORD=$SELECT($GET(ON)["P":ON,$GET(ON55)["P":ON55,1:"")
SET ZORN=+$PIECE(^PS(53.1,+PSJDGORD,0),U,21)
SET PSJDALOC=+PSJDGORD_"P"
QUIT
+20 IF $GET(ON)["U"!($GET(ON55)["U")
SET PSJDGORD=$SELECT($GET(ON)["U":ON,$GET(ON55)["U":ON55,1:"")
SET ZORN=+$PIECE(^PS(55,DFN,5,+PSJDGORD,0),U,21)
SET PSJDALOC=DFN_"U"_+PSJDGORD
QUIT
+21 IF $GET(ON)["V"!($GET(ON55)["V")
SET PSJDGORD=$SELECT($GET(ON)["V":ON,$GET(ON55)["V":ON55,1:"")
SET ZORN=+$PIECE(^PS(55,DFN,"IV",+PSJDGORD,0),U,21)
SET PSJDALOC=DFN_"V"_+PSJDGORD
End DoDot:1
+22 ;
+23 if '$DATA(PSJDAOC)
SET PSJDAOC="IP"
+24 IF '$GET(ZORN)
WRITE !!,"NO Drug Allergy Order Checks found."
GOTO EXT
+25 ;set up variables for order check
DO SET3^PSJNEWOC
+26 SET PSJDAOC=$GET(PSJDAOC)_"Allergy"
+27 IF $LENGTH(PSJDAOC)>40
SET PSJDAOC=$EXTRACT(PSJDAOC,1,40)
+28 KILL ^TMP("PSJDAOCD",$JOB),^TMP("PSJAL",$JOB),RET
SET RET=""
+29 DO GETOC4^OROCAPI1(ZORN,.RET)
+30 IF $ORDER(RET(ZORN,"DATA",""))=""
SET FLAG2=1
+31 ;
+32 FOR ZI=0:0
SET ZI=$ORDER(RET(ZORN,"DATA",ZI))
if 'ZI
QUIT
IF +$PIECE(RET(ZORN,"DATA",ZI,1),";",2)=3
SET ZCNTT=1
+33 IF 'ZCNTT
SET FLAG2=1
WRITE !!,"NO Drug Allergy Order Checks found."
SET PSJNOALL=1
GOTO EXT
+34 ;
SORT ;build sort by severity, reactant/causitive agent
+1 KILL PSJASORT
+2 NEW ZIIEN,ZSIEN,ZSIGNS,SIGN,SIGNS,PSJPTLOC,PSJINST,PSJDCLAS,PSJIEN70,PSJIEN60,PSJDFLAG,PSJRETI,PSJAIENS,PSJDRCL2
+3 NEW PSJFROM1,PSJREAB,PSJREAS,I
+4 FOR ZI=0:0
SET ZI=$ORDER(RET(ZORN,"DATA",ZI))
if 'ZI
QUIT
IF $DATA(RET(ZORN,"DATA",ZI,1))
Begin DoDot:1
+5 if +$PIECE(RET(ZORN,"DATA",ZI,1),";",2)'=3
QUIT
+6 IF $GET(RET(ZORN,"DATA",ZI,"OR",1,0))]""
SET ^TMP("PSJDAOCD",$JOB,"AOR",$GET(RET(ZORN,"DATA",ZI,"OR",1,0)))=""
+7 KILL PSJAIENS
+8 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
+9 if $PIECE(^ORD(100.05,ZI,0),"^",3)["CPRS"
QUIT
+10 SET (PSJZERO,PSJREAB,PSJREA,PSJREAS,PSJTYPE,PSJRSITE,PSJSSITE,PSJASEV,PSJASEV2,PSJDRGCL,PSJIEN70,PSJIEN60,PSJDFLAG,PSJRETI,PSJFROM1)=""
+11 ;
+12 DO GETS^DIQ(100.05,ZI,"70*","I","PSJIEN70")
DO GETS^DIQ(100.05,ZI,"60*","I","PSJIEN60")
+13 SET PSJDFLAG=""
SET PSJDFLAG=$$GETORD^PSJNEWOA(ZI,PSJDGORD,PSJDFLAG)
+14 if 'PSJDFLAG
QUIT
+15 ;
+16 SET PSJZERO=$GET(^ORD(100.05,ZI,4,ZIIEN,0))
+17 SET PSJREAB=$PIECE(PSJZERO,"^")
SET PSJFROM1=$PIECE(PSJZERO,"^",2)
SET PSJASEV=$PIECE(PSJZERO,"^",7)
SET PSJTYPE=$PIECE(PSJZERO,"^",3)
+18 SET PSJRSITE=$PIECE(PSJZERO,"^",4)
SET PSJASEV2=$SELECT(PSJASEV=3:"A",PSJASEV="2":"B",PSJASEV=1:"C",1:"D")
+19 IF PSJREAB["/"
Begin DoDot:3
+20 FOR I=1:1
SET PSJREAS=$PIECE(PSJREAB,"/",I)
if PSJREAS=""
QUIT
SET PSJREA=PSJREA_"/ "_PSJREAS
End DoDot:3
SET PSJREA=$EXTRACT(PSJREA,3,$LENGTH(PSJREA))
+21 IF PSJREAB'["/"
SET PSJREA=PSJREAB
+22 ;DRUG CLASS
+23 SET (PSJCAGNT,PSJDRGCL,PSJDCLAS,PSJDRCL2)=""
+24 FOR ZZQ=0:0
SET ZZQ=$ORDER(^ORD(100.05,ZI,4,ZIIEN,1,ZZQ))
if 'ZZQ!(ZZQ'?1N.N)
QUIT
Begin DoDot:3
+25 SET PSJDRCL2=^ORD(100.05,ZI,4,ZIIEN,1,ZZQ,0)
SET PSJDCLAS=1
+26 SET PSJDRGCL=PSJDRGCL_"|"_$$GET1^DIQ(50.605,PSJDRCL2,1)
End DoDot:3
+27 IF PSJDRGCL'?1A.AP
SET PSJDRGCL=$EXTRACT(PSJDRGCL,2,999)
+28 if PSJDRGCL=""!(PSJDRGCL="|")
SET PSJDRGCL="aaaa"
+29 SET PSJCAGNT=$SELECT(PSJDRGCL'="aaaa":PSJDRGCL,1:$PIECE(PSJREA,"|",1))
+30 SET (PSJDOI,PSJDOIN,PROSPECT,DRUGIEN)=""
+31 ;
+32 IF $DATA(^ORD(100.05,ZI,5,1,0))
SET DRUGIEN=^ORD(100.05,ZI,5,1,0)
+33 IF DRUGIEN'=""
Begin DoDot:3
+34 SET DRUG=$$GET1^DIQ(50,DRUGIEN,.01,"E")
SET PSJOIN=$$GET1^DIQ(50,DRUGIEN,2.1,"E")
+35 ;GENERIC NAME
SET PROSPECT=DRUG
+36 ;orderable item if IV
IF $GET(PSJDGORD)["V"!($GET(PSJDGORD)["P")&($DATA(^PS(53.1,+$GET(PSJDGORD),"AD")))
SET PROSPECT=PSJOIN
End DoDot:3
+37 if PROSPECT=""
QUIT
+38 IF PSJTYPE="L"
SET PSJRSITE=$$INST^PSJGMRA($GET(PSJDALOC))
+39 ;
+40 IF $DATA(PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,0))
Begin DoDot:3
+41 if PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,0)'[(ZIIEN_"^"_ZI)
SET PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,0)=PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,0)_"|"_ZIIEN_"^"_ZI_"^"_PSJCAGNT
End DoDot:3
+42 IF '$DATA(PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,0))
SET PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,0)=ZIIEN_"^"_ZI_"^"_PSJCAGNT
+43 SET PSJDATA=""
SET PSJDATA=PSJTYPE_"|"_PSJRSITE_"|"_$PIECE(PSJZERO,"^",5)
+44 IF $DATA(PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,1))
Begin DoDot:3
+45 if PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,1)'[PSJDATA
SET PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,1)=PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,1)_"^"_PSJDATA
End DoDot:3
+46 IF '$DATA(PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,1))
SET PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,1)=PSJDATA
SET FLAG2=1
+47 ;SIGNS AND SYMPTOMS
+48 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
+49 SET ZSIGNS=^ORD(100.05,ZI,4,ZIIEN,3,ZSIEN,0)
+50 IF '$DATA(PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,2))
SET PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,2)=ZSIGNS
QUIT
+51 if PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,2)'[("|"_ZSIGNS_"|")
SET PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,2)=PSJASORT(PROSPECT,PSJASEV2,PSJREA,PSJFROM1,2)_"|"_ZSIGNS
End DoDot:3
End DoDot:2
End DoDot:1
+52 ;
+53 IF 'FLAG2
WRITE !!,"NO Drug Allergy Order Checks found."
SET PSJNOALL=1
GOTO EXT
+54 ;
LOOP ;
+1 ;**** Begin looping through sort
+2 SET (PSJASEV,PSJREA,PSJTYPE,ZIIEN,PROSPECT,PSJDRGCL,PSJCAGNT,PSJFROM1)=""
+3 FOR
SET PROSPECT=$ORDER(PSJASORT(PROSPECT))
if PROSPECT=""
QUIT
Begin DoDot:1
+4 SET IEN=$GET(IEN)+1
SET ^TMP("PSJAL",$JOB,IEN,0)="A Drug-Allergy Reaction exists for this medication and/or class!"
+5 SET IEN=$GET(IEN)+1
SET ^TMP("PSJAL",$JOB,IEN,0)=" "
+6 FOR
SET PSJASEV=$ORDER(PSJASORT(PROSPECT,PSJASEV))
if PSJASEV=""
QUIT
Begin DoDot:2
+7 FOR
SET PSJCAGNT=$ORDER(PSJASORT(PROSPECT,PSJASEV,PSJCAGNT))
if PSJCAGNT=""
QUIT
Begin DoDot:3
+8 FOR
SET PSJFROM1=$ORDER(PSJASORT(PROSPECT,PSJASEV,PSJCAGNT,PSJFROM1))
if PSJFROM1=""
QUIT
DO ADOC
End DoDot:3
End DoDot:2
End DoDot:1
+9 ;
PRT ; print allergy information to screen
+1 DO FULL^VALM1
WRITE @IOF
+2 NEW ZZ,PRTFLG,PRTFLG3
SET (PRTFLG3,PRTFLG)=0
+3 WRITE $CHAR(7),!
+4 SET ZZ=""
FOR
SET ZZ=$ORDER(^TMP("PSJAL",$JOB,ZZ))
if ZZ=""
QUIT
Begin DoDot:1
+5 SET PSJDATA=""
SET PSJDATA=$GET(^TMP("PSJAL",$JOB,ZZ,0))
+6 IF PRTFLG
Begin DoDot:2
+7 IF PSJDATA["A Drug-Allergy Reaction exists for this medication and/or class"
DO EXT
SET (PRTFLG3,PRTFLG)=0
End DoDot:2
+8 IF PSJDATA["Prospective Drug"
SET PRTFLG3=PRTFLG3+1
+9 IF PRTFLG
IF PRTFLG3>1
IF PSJDATA["Prospective Drug"
DO EXT
WRITE !
+10 WRITE !,PSJDATA
SET PRTFLG=1
IF ($Y+3)>IOSL
DO FF
End DoDot:1
if PSJQUIT
GOTO EXIT
+11 ;
+12 KILL DIR,DUOUT,DIRUT
+13 if PSJQUIT
GOTO EXIT
+14 IF $GET(PRTFLG)
WRITE !
DO FF
+15 GOTO EXIT
+16 QUIT
+17 ;
ADOC ;
+1 NEW ING,SS,DC,OH,CAG,CAUS,SEVT,SEVN,ZALL,Z,ZX,ZALL,FIRST,DRUGIEN,DRUG,DRUGS,ZCX,PSJWCA,CAUS2,CAUS3,ZLOC,PSJCAR,FLAG,I,ZDATE
+2 NEW SITE,SITET,SITED,I,ZDATA,PSJSITE,PSJCSITE,CAUS4,PSJRDAT2,PSJNCOM,PSJNCOM1,PSJCOI,PSJCU,PSJCDF,PSJCPROS
+3 SET (PSJRSITE,PSJRDATA)=""
+4 SET PSJRDATA=PSJASORT(PROSPECT,PSJASEV,PSJCAGNT,PSJFROM1,0)
+5 ;RTC 190465 - DA not display when allergy contains 2 or more VA Classes
+6 ;F I=1:1 S PSJRDAT2=$P(PSJRDATA,"|",I) Q:PSJRDAT2=""
+7 ;S:(I-1)>0 XXI=$P(PSJRDATA,"|",I-1)
+8 ;S ZI=$P(XXI,"^",2),XXI=+XXI
+9 SET ZI=$PIECE(PSJRDATA,"^",2)
SET XXI=+PSJRDATA
+10 SET PSJRSITE=PSJASORT(PROSPECT,PSJASEV,PSJCAGNT,PSJFROM1,1)
+11 ;
+12 if XXI'>0
QUIT
+13 if '+ZI
QUIT
+14 if $PIECE($GET(^ORD(100.05,ZI,4,XXI,0)),"^")']""
QUIT
+15 SET (SEVT,SEVN,CAUS,CAUS3,CAUS2,CAUS4,PSJWCA,PSJCAR,OH,DRUG,DRUGS,X,ING,SS,DC,ZALL,ZLOC,ZDATE)=""
+16 SET ZALL=$GET(^ORD(100.05,ZI,4,XXI,0))
SET ZLOC=$PIECE(ZALL,"^",3)
+17 SET CAUS=$PIECE(ZALL,"^",1)
SET CAUS2=$PIECE($PIECE(ZALL,"^",2),";")
SET CAUS3=$$GET1^DIQ(50.6,CAUS2,.01,"E")
+18 SET SEVT=$PIECE(ZALL,"^",7)
SET SEVN=$SELECT(SEVT=1:"MILD",SEVT=2:"MODERATE",SEVT=3:"SEVERE",1:"Not Entered")
+19 SET ^TMP("PSJDAOCD",$JOB,"CA",CAUS)=""
+20 SET CAUS=PSJCAGNT
SET PSJCSITE=""
+21 ;**** PARSE OUT SITES
+22 IF CAUS'?1A.AP
SET CAUS=$PIECE(ZALL,"^",1)
+23 IF PSJRSITE'["^"
Begin DoDot:1
+24 SET ZDATE=$PIECE(PSJRSITE,"|",3)
SET ZDATE=$SELECT(ZDATE'="":$EXTRACT(ZDATE,4,5)_"/"_$EXTRACT(ZDATE,6,7)_"/"_$EXTRACT(ZDATE,2,3),1:"")
+25 SET PSJCSITE=$PIECE(PSJRSITE,"|",2)
SET PSJCSITE=$$GET1^DIQ(4,PSJCSITE,.01)
+26 SET PSJCSITE=$SELECT(PSJCSITE'="":PSJCSITE,ZLOC="L":"LOCAL",ZLOC="R":"REMOTE",1:"Not Given")
+27 SET PSJCAR=CAUS_" ("_PSJCSITE_" - "_ZDATE_")"
End DoDot:1
+28 IF PSJRSITE["^"
Begin DoDot:1
+29 FOR I=1:1
SET ZDATA=$PIECE(PSJRSITE,"^",I)
if ZDATA=""
QUIT
SET PSJCSITE=""
Begin DoDot:2
+30 SET ZDATE=$PIECE(ZDATA,"|",3)
SET ZDATE=$SELECT(ZDATE'="":$EXTRACT(ZDATE,4,5)_"/"_$EXTRACT(ZDATE,6,7)_"/"_$EXTRACT(ZDATE,2,3),1:"")
+31 SET PSJCSITE=$PIECE(ZDATA,"|",2)
SET PSJCSITE=$$GET1^DIQ(4,PSJCSITE,.01)
+32 SET PSJCSITE=$SELECT(PSJCSITE'="":PSJCSITE,ZLOC="L":"LOCAL",ZLOC="R":"REMOTE",1:"Not Given")
+33 SET PSJCAR=PSJCAR_", "_PSJCSITE_" - "_ZDATE
End DoDot:2
End DoDot:1
if PSJCAR'=""
SET PSJCAR=CAUS_" ("_$EXTRACT(PSJCAR,3,999)_")"
+34 ;****
+35 IF PSJCAR=""
SET PSJCAR=CAUS
+36 SET (PSJNCOM1,PSJCPROS)=""
SET PSJNCOM1=$$FINDC($GET(PSJORD))
if +$GET(PSJNCOM1)
SET PSJCPROS=$PIECE(PSJNCOM1,"^",2)
SET PSJNCOM1=$PIECE(PSJNCOM1,"^")
+37 SET IEN=$GET(IEN)+1
SET ^TMP("PSJAL",$JOB,IEN,0)=" Prospective Drug: "_$SELECT($GET(PSJNCOM1):PSJCPROS,1:PROSPECT)
+38 SET OH=$$UPPER($PIECE(ZALL,"^",6))
SET ^TMP("PSJDAOCD",$JOB,"OH")=OH
+39 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=58
SET DIWF=""
+40 SET X=PSJCAR
+41 DO ^DIWP
SET FIRST=1
+42 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=$GET(IEN)+1
SET ^TMP("PSJAL",$JOB,IEN,0)=$SELECT(FIRST:" Causative Agent: "_^UTILITY($JOB,"W",1,ZCX,0),1:" "_^UTILITY($JOB,"W",1,ZCX,0))
SET FIRST=0
+43 SET IEN=IEN+1
SET ^TMP("PSJAL",$JOB,IEN,0)="Historical/Observed: "_$SELECT(OH="H":"HISTORICAL",OH="O":"OBSERVED",1:"Not Entered")
+44 SET IEN=IEN+1
SET ^TMP("PSJAL",$JOB,IEN,0)=" Severity: "_$GET(SEVN)
+45 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=58
SET DIWF=""
INGRED ;
+1 ; DRUG INGREDIENT
+2 SET FLAG=0
KILL ^TMP("PSJDAOCD",$JOB,"DI")
NEW PSJDRCL3
+3 FOR ZZQ=0:0
SET ZZQ=$ORDER(^ORD(100.05,ZI,4,XXI,2,ZZQ))
if 'ZZQ
QUIT
SET ^TMP("PSJDAOCD",$JOB,"DI",$PIECE(^PS(50.416,$PIECE(^ORD(100.05,ZI,4,XXI,2,ZZQ,0),"^"),0),"^"))=""
SET FLAG=1
+4 SET X=""
+5 FOR
SET ING=$ORDER(^TMP("PSJDAOCD",$JOB,"DI",ING))
if ING=""
QUIT
SET X=X_", "_ING
+6 SET X=$EXTRACT(X,3,999)
+7 ;S X=$P(ZALL,"^",1)
+8 IF X'=""
Begin DoDot:1
+9 DO ^DIWP
+10 SET FIRST=1
+11 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("PSJAL",$JOB,IEN,0)=$SELECT(FIRST:" Ingredients: "_^UTILITY($JOB,"W",1,ZX,0),1:" "_^UTILITY($JOB,"W",1,ZX,0))
SET FIRST=0
End DoDot:1
SIGNS ;
+1 ; SIGNS/SYMPTOMS
+2 KILL ^UTILITY($JOB,"W"),^TMP("PSJDAOCD",$JOB,"SS")
SET DIWL=1
SET DIWR=58
SET DIWF=""
SET ING=""
+3 SET (X,SIGNS,SIGN)=""
SET SIGNS=$GET(PSJASORT(PROSPECT,PSJASEV,PSJCAGNT,PSJFROM1,2))
+4 IF SIGNS'=""
FOR ZZQ=1:1
SET SIGN=$PIECE(SIGNS,"|",ZZQ)
if SIGN=""
QUIT
Begin DoDot:1
+5 IF $GET(^GMRD(120.83,SIGN,0))]""
SET ^TMP("PSJDAOCD",$JOB,"SS",$PIECE(^GMRD(120.83,SIGN,0),"^"))=""
End DoDot:1
+6 SET X=""
SET FIRST=1
+7 IF $ORDER(^TMP("PSJDAOCD",$JOB,"SS",""))]""
SET SS=""
Begin DoDot:1
+8 FOR
SET SS=$ORDER(^TMP("PSJDAOCD",$JOB,"SS",SS))
if SS=""
QUIT
SET X=X_", "_SS
End DoDot:1
+9 SET X=$EXTRACT(X,3,999)
DO ^DIWP
+10 FOR ZX=0:0
SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
if 'ZX
QUIT
SET IEN=IEN+1
SET ^TMP("PSJAL",$JOB,IEN,0)=$SELECT(FIRST:" Signs/Symptoms: "_$SELECT(SIGNS="":"None Entered",1:^UTILITY($JOB,"W",1,ZX,0)),1:" "_^UTILITY($JOB,"W",1,ZX,0))
SET FIRST=0
+11 KILL ^UTILITY($JOB,"W")
+12 ; DRUG CLASS
+13 SET DIWL=1
SET DIWR=58
SET DIWF=""
KILL ^TMP("PSJDAOCD",$JOB,"DC")
+14 FOR ZZQ=0:0
SET ZZQ=$ORDER(^ORD(100.05,ZI,4,XXI,1,ZZQ))
if 'ZZQ
QUIT
Begin DoDot:1
+15 SET PSJDRCL3=""
SET PSJDRCL3=$PIECE(^PS(50.605,+$PIECE(^ORD(100.05,ZI,4,XXI,1,ZZQ,0),"^"),0),"^")
SET ^TMP("PSJDAOCD",$JOB,"DC",+$PIECE(^ORD(100.05,ZI,4,XXI,1,ZZQ,0),"^"))=PSJDRCL3_" "_$PIECE($GET(^PS(50.605,+$PIECE($GET(^ORD(100.05,ZI,4,XXI,1,ZZQ,0)),"^"),0)),"^",2)
End DoDot:1
+16 SET X=""
SET FIRST=1
+17 FOR DC=0:0
SET DC=$ORDER(^TMP("PSJDAOCD",$JOB,"DC",DC))
if 'DC
QUIT
SET X=X_", "_^TMP("PSJDAOCD",$JOB,"DC",DC)
Begin DoDot:1
+18 IF $LENGTH(X)>234
SET X=$EXTRACT(X,3,999)
DO ^DIWP
SET X=""
End DoDot:1
+19 IF X'=""
SET X=$EXTRACT(X,3,999)
+20 IF X'=""
Begin DoDot:1
+21 DO ^DIWP
+22 FOR ZX=0:0
SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
if 'ZX
QUIT
SET IEN=IEN+1
SET ^TMP("PSJAL",$JOB,IEN,0)=$SELECT(FIRST:" Drug Class: "_^UTILITY($JOB,"W",1,ZX,0),1:" "_^UTILITY($JOB,"W",1,ZX,0))
SET FIRST=0
+23 KILL ^UTILITY($JOB,"W")
NEW Z,ZX
End DoDot:1
+24 ; intervention
DO INV
+25 QUIT
+26 ;
UPPER(PSJUCS) ;
+1 QUIT $TRANSLATE(PSJUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
LOWER(PSJLCS) ;
+1 QUIT $TRANSLATE(PSJLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
+2 ;
EXT ;
+1 KILL DIR,DUOUT,DIRUT,ZFND
+2 IF $GET(PSJNOALL)
DO FULL^VALM1
DO PAUSE^VALM1
SET VALMBCK="R"
KILL PSJQUIT,DIR,DUOUT,DIRUT
QUIT
+3 DO FF
+4 IF $DATA(DIRUT)
GOTO EXIT
+5 QUIT
EXIT ;
+1 IF $GET(PSJNOALL)
DO FULL^VALM1
DO PAUSE^VALM1
KILL PSJQUIT
+2 SET VALMBCK="R"
KILL DIR,DUOUT,DIRUT,^TMP("PSJDAOCD",$JOB),^TMP("PSJAL",$JOB),ZPGK
+3 QUIT
+4 ;
INV ;display intervention
+1 ;changed to add Provider & Pharmacist and put in current sequence [ST - 6.17.2014]
+2 SET IEN=$GET(IEN)+1
SET ^TMP("PSJAL",$JOB,IEN,0)=" "
+3 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=55
SET DIWF=""
+4 SET PSJPROV=""
SET PSJPROV="N/A - Order Check Not Evaluated by Provider"
+5 IF $ORDER(^TMP("PSJDAOCD",$JOB,"AOR",""))]""
SET PSJPROV=$ORDER(^TMP("PSJDAOCD",$JOB,"AOR",""))
+6 SET X=PSJPROV
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("PSJAL",$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=$GET(IEN)+1
SET ^TMP("PSJAL",$JOB,IEN,0)=" "
+9 ;
+10 IF $PIECE($GET(^ORD(100.05,ZI,8)),"^")=""
Begin DoDot:1
+11 SET IEN=IEN+1
SET ^TMP("PSJAL",$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("PSJAL",$JOB,IEN,0)="Intervention Date: "_INTY(9009032.4,DA,.01)
+14 SET IEN=IEN+1
SET ^TMP("PSJAL",$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("PSJAL",$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("PSJAL",$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 PSJQUIT=1
+4 KILL DIR,DUOUT,DIRUT,DTOUT,L
+5 WRITE @IOF
+6 QUIT
+7 ;
FINDC(PSJORD) ;determine if order is part of a complex UD order
+1 ;for complex UD orders display format: orderable item doseform (units) ex: MORPHINE TAB,SA (100MG)
+2 if PSJORD=""
QUIT
+3 NEW PSJCOMD,PSJCOI,PSJCU,PSJCDF,PSJCPROS
+4 SET (PSJCOMD,PSJCOI,PSJCU,PSJCDF,PSJCPROS,PSJNCOM)=""
+5 IF $GET(PSJORD)["P"!($GET(PSJORD)["N")
DO FINDCP
+6 IF '$TEST
DO FINDCA
+7 QUIT PSJNCOM_"^"_PSJCPROS
+8 ;
FINDCP ;COMPLEX PENDING ORDER
+1 SET PSJNCOM=+$PIECE($GET(^PS(53.1,+PSJORD,.2)),"^",8)
+2 IF $GET(PSJNCOM)
Begin DoDot:1
+3 DO GETS^DIQ(53.1,+PSJORD,"108;109","EI","PSJCOMD")
+4 SET PSJCU=PSJCOMD(53.1,+PSJORD_",",109,"E")
SET PSJCOI=PSJCOMD(53.1,+PSJORD_",",108,"E")
+5 IF PSJCOI'=""
SET PSJCDF=$$GET1^DIQ(50.7,$GET(PSJCOMD(53.1,+PSJORD_",",108,"I")),.02,"E")
+6 SET PSJCPROS=$SELECT(PSJCOI'="":PSJCOI_" "_PSJCDF_" ("_PSJCU_")",1:PROSPECT)
End DoDot:1
+7 QUIT
+8 ;
FINDCA ;COMPLEX ACTIVE ORDER
+1 NEW PSJCPRSO
SET PSJCPRSO=""
SET PSJCPRSO=$$GET1^DIQ(55.06,+PSJORD_","_DFN_",",125,"I")
+2 if PSJCPRSO=""
QUIT
+3 IF $DATA(^PS(55,"ACX",PSJCPRSO))
SET PSJNCOM=1
Begin DoDot:1
+4 DO GETS^DIQ(55.06,+PSJORD_","_DFN_",","108;109","IE","PSJCOMD")
+5 SET PSJCOI=$GET(PSJCOMD(55.06,+PSJORD_","_DFN_",",108,"E"))
SET PSJCU=$GET(PSJCOMD(55.06,+PSJORD_","_DFN_",",109,"E"))
+6 IF PSJCOI'=""
SET PSJCDF=$$GET1^DIQ(50.7,$GET(PSJCOMD(55.06,+PSJORD_",742,",108,"I")),.02,"E")
+7 SET PSJCPROS=$SELECT(PSJCOI'="":PSJCOI_" "_PSJCDF_" ("_PSJCU_")",1:PROSPECT)
End DoDot:1
+8 QUIT
