Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSODRG

PSODRG.m

Go to the documentation of this file.
  1. PSODRG ;IHS/DSD/JCM - ORDER ENTRY DRUG SELECTION ;10/23/18 8:47am
  1. ;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,207,148,243,268,324,251,375,387,398,390,427,411,458,504,517,457,574,524,747**;DEC 1997;Build 7
  1. ; Reference to ^PSDRUG( in ICR #221
  1. ; Reference to ^PS(50.7 in ICR #2223
  1. ; Reference to $$PROMPT^PSSDIN in ICR #3166
  1. ; Reference to EN^PSSDIN in ICR #3166
  1. ; Reference to $$GETNDC^PSSNDCUT in ICR #4707
  1. ; Reference to ^OROCAPI in ICR #5367
  1. ; Reference to $$OITM^ORX8 in ICR #5469
  1. ; Reference to ^VADPT in ICR #10061
  1. ; Reference to IN^PSSHRQ2 in ICR #5369
  1. ; Reference to ^XTMP("ORRDI" in ICR #5440
  1. ;
  1. ;*524 Add HAZ Handle & Haz Dispose Alert pre-order checks
  1. ;----------------------------------------------------------
  1. START ;
  1. S (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0 K PSORX("DFLG")
  1. D @($S(+$G(PSOEDIT)=1&('$D(DA)):"SELECT^PSODRGN",1:"SELECT"))
  1. G:$G(PSORXED("DFLG")) END ; Select Drug
  1. ;PATCH PSO*7*517 - Blocking action FN if issuing a controlled substance to a patient without a zipcode
  1. N DRGIEN S DRGIEN=$P($G(PSOY),U)
  1. I $$CSBLOCK^PSOORNEW(PSODFN,DRGIEN) D S DIR(0)="E" W ! D ^DIR K DIR,Y G END
  1. .W !,"Controlled substance prescriptions require a patient address. Please update"
  1. .W !,"patient address information. This action will also invalidate a digitally"
  1. .W !,"signed prescription and require the provider to re-enter the order."
  1. .S PSONEW("DFLG")=1
  1. ;PSO*7*517 - END
  1. I $G(PSORX("EDIT")),$G(PSOY),$G(PSODRUG("IEN"))=+PSOY D G:$G(PSORXED("DFLG")) END
  1. . N NDC D NDC(+$G(PSORXED("IRXN")),0,+PSOY,.NDC) I $G(NDC)="^" S PSORXED("DFLG")=1 Q
  1. . I $G(NDC)'="" S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
  1. ;
  1. I $G(PSORX("EDIT"))]"",'PSONEW("FIELD") D TRADE
  1. G:$G(PSONEW("DFLG"))!($G(PSODRG("QFLG")))!($G(PSORXED("DFLG"))) END
  1. D SET ; Set various drug information
  1. D NFI ; Display dispense drug/orderable item text
  1. D:'$G(PSOEDIT) POST I $G(PSORX("DFLG")) S PSONEW("DFLG")=1 K:'$G(PSORX("EDIT")) PSORX("DFLG") ; Do any post selection action
  1. END ;D EOJ
  1. Q
  1. ;------------------------------------------------------------
  1. ;
  1. SELECT ;
  1. K:'$G(PSORXED) CLOZPAT
  1. K IT,DIC,X,Y,PSODRUG("TRADE NAME"),PSODRUG("NDC"),PSODRUG("DAW"),PSODRUG("BAD") S:$G(POERR)&($P($G(OR0),"^",9)) Y=$$GET1^DIQ(50,$P(OR0,"^",9),.01)
  1. I $G(PSODRUG("IEN"))]"" S Y=PSODRUG("NAME"),PSONEW("OLD VAL")=PSODRUG("IEN")
  1. W !,"DRUG: "_$S($G(Y)]"":Y_"// ",1:"") R X:$S($D(DTIME):DTIME,1:300) I '$T S DTOUT=1
  1. I X="",$G(Y)]"" S:Y X=Y S:'X X=$G(PSODRUG("IEN")) S:X X="`"_X
  1. G:X="" SELECT
  1. I X?1."?" W !!,"Answer with DRUG NUMBER, or GENERIC NAME, or VA PRODUCT NAME, or",!,"NATIONAL DRUG CLASS, or SYNONYM" G SELECT
  1. I $G(PSORXED),X["^" S PSORXED("DFLG")=1 G SELECTX
  1. I X="^"!(X["^^")!($D(DTOUT)) S PSONEW("DFLG")=1 G SELECTX
  1. I '$G(POERR),X[U,$L(X)>1 S PSODIR("FLD")=PSONEW("FLD") D JUMP^PSODIR1 S:$G(PSODIR("FIELD")) PSONEW("FIELD")=PSODIR("FIELD") K PSODIR S PSODRG("QFLG")=1 G SELECTX
  1. S DIC=50,DIC(0)="EMQZVT",DIC("T")="",D="B^C^VAPN^VAC"
  1. S DIC("S")="I $S('$$GET1^DIQ(50,+Y,100,""I""):1,DT'>$$GET1^DIQ(50,+Y,100,""I""):1,1:0),$S($$GET1^DIQ(50,+Y,63,""I"")'[""O"":0,1:1)" ;,$D(^PSDRUG(""ASP"",+$G(^(2)),+Y))"
  1. D MIX^DIC1 K DIC,D
  1. I $D(DTOUT) S PSONEW("DFLG")=1 G SELECTX
  1. I $D(DUOUT) K DUOUT G SELECT
  1. I Y<0 G SELECT
  1. S:$G(PSONEW("OLD VAL"))=+Y&('$G(PSOEDIT)) PSODRG("QFLG")=1
  1. K PSOY S PSOY=Y,PSOY(0)=Y(0)
  1. I $P(PSOY(0),"^")="OTHER DRUG"!($P(PSOY(0),"^")="OUTSIDE DRUG") D TRADE
  1. SELECTX K X,Y,DTOUT,DUOUT,PSONEW("OLD VAL")
  1. Q
  1. ;
  1. NDC(RX,RFL,DRG,NDC) ; Editing NDC for Released Rx's or for Unresolved ECME Rejects
  1. S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
  1. ; Check if we should edit the NDC
  1. ; Needs to be released or have unresolved billable rejects (PSO*7*427)
  1. ;
  1. N PSOCONT S PSOCONT=0 ; continue flag
  1. D Q:'PSOCONT ; get out if NDC edit not allowed
  1. . I $$RXRLDT^PSOBPSUT(RX,RFL) S PSOCONT=1 Q ; Released - continue and allow edit
  1. . I $$FIND^PSOREJUT(RX,RFL),$$STATUS^PSOBPSUT(RX,RFL)'="" S PSOCONT=1 Q ; unreleased w/unresolved billable rejections
  1. . Q
  1. ;
  1. S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
  1. D NDCEDT^PSONDCUT(RX,.RFL,$G(DRG),$G(PSOSITE),.NDC)
  1. Q
  1. ;
  1. TRADE ;
  1. K DIR,DIC,DA,X,Y
  1. S DIR(0)="52,6.5" S:$G(PSOTRN)]"" DIR("B")=$G(PSOTRN) D ^DIR K DIR,DIC
  1. I X="@" S Y=X K DIRUT
  1. I $D(DIRUT) S:$D(DUOUT)!$D(DTOUT)&('$D(PSORX("EDIT"))) PSONEW("DFLG")=1 G TRADEX
  1. S PSODRUG("TRADE NAME")=Y
  1. TRADEX I $G(PSORXED("DFLG")),$D(DIRUT) S PSORXED("DFLG")=1
  1. K DIRUT,DTOUT,DUOUT,X,Y,DA,DR,DIE
  1. Q
  1. SET ;
  1. N PSOHZ S PSOHZ=0 ;init haz alert shown to user=no *524
  1. N STAT S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2)
  1. S PSODRUG("NAME")=$P(PSOY(0),"^")
  1. S PSODRUG("OI")=+$$GET1^DIQ(50,+PSOY,2.1,"I"),PSODRUG("OIN")=$$GET1^DIQ(50,+PSOY,2.1)
  1. S PSODRUG("NDF")=$S(PSODRUG("OI"):$$GET1^DIQ(50,+PSOY,20,"I")_"A"_$$GET1^DIQ(50,+PSOY,22,"I"),1:0)
  1. S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3)
  1. ; (#25) NATIONAL DRUG CLASS [6P:50.605]
  1. S PSODRUG("CLN")=+$$GET1^DIQ(50,+PSOY,25,"I") ; zero if field is null
  1. S PSODRUG("SIG")=$P(PSOY(0),"^",5)
  1. I $G(PSODRUG("NDC"))="" S PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$G(PSOSITE))
  1. S PSODRUG("DAW")=$$GET1^DIQ(50,+PSOY,81)
  1. I PSODRUG("DAW")="" S PSODRUG("DAW")=0
  1. S PSODRUG("STKLVL")=$$GET1^DIQ(50,+PSOY,50)
  1. ;PSO*7*574 - Defect 1181628 Replaced code for PRICE PER DISPENSE UNIT display
  1. G:$G(^PSDRUG(+PSOY,660))']"" SETX
  1. S PSOX1=$G(^PSDRUG(+PSOY,660))
  1. S PSODRUG("COST")=$$GET1^DIQ(50,+PSOY,16) ; PSO*7*574 changed field to (#16) PRICE PER DISPENSE UNIT [6N]
  1. S PSODRUG("UNIT")=$$GET1^DIQ(50,+PSOY,14.5)
  1. S PSODRUG("EXPIRATION DATE")=$$GET1^DIQ(50,+PSOY,17.1,"I")
  1. SETX K PSOX1,PSOY
  1. Q
  1. NFI ;display restriction/guidelines
  1. D EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN")) S NFI=$$PROMPT^PSSDIN
  1. I NFI]"","ODY"[NFI D TD^PSONFI
  1. K NFI Q
  1. POST ;order checks
  1. ;add Hazardous to Handle/Dispose warning messages *524
  1. N HAZ,HAZH,HAZD,HTXT,LL S HAZ=$$HAZ^PSSUTIL(PSODRUG("IEN")),HAZH=$P(HAZ,U),HAZD=$P(HAZ,U,2)
  1. I ('$G(PSOHZ)!(PSODRUG("IEN")'=$G(PSOLSTDR))),(HAZH!HAZD) D
  1. . S PSOHZ=1,PSOLSTDR=PSODRUG("IEN")
  1. . D HAZWARNG^PSSUTIL(PSODRUG("IEN"),"O",HAZH,HAZD,.HTXT)
  1. . S $P(LL,"-",80)="-"
  1. . W #,$C(7),LL,!
  1. . W $J("***** WARNING *****",47)
  1. . D WRAPTEXT(HTXT,65,5) W !
  1. . W LL,!
  1. . K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR
  1. N LIST S LIST="PSOPEPS"
  1. K PSODOSD,^TMP("PSORXDC",$J),^TMP($J,LIST),^TMP("PSODAOC",$J)
  1. K ZDGDG,ZTHER,IT,PSODLQT,PSODOSD
  1. I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) S ^TMP("PSODAOC",$J,"NORDI",1,0)="Remote data not available - Only local order checks processed."
  1. S ^TMP($J,LIST,"IN","PING")="" D IN^PSSHRQ2(LIST)
  1. K DIR I $P(^TMP($J,LIST,"OUT",0),"^")=-1 D
  1. .D DATACK^PSODDPRE
  1. .S ^TMP("PSODAOC",$J,"NOSYS",1,0)="No Enhanced Order Checks can be performed. Reason(s): "_$P($G(^TMP($J,LIST,"OUT",0)),"^",2)
  1. K ^TMP($J,LIST,"IN"),^TMP($J,LIST,"OUT","EXCEPTIONS")
  1. G:$G(PSORX("DFLG"))!($G(PSORXED("DFLG"))) POSTX
  1. K PSORX("INTERVENE"),PSOQUIT N STAT,SIG,PTR,NDF,VAP S PSORX("DFLG")=0
  1. W !! D HD^PSODDPR2():(($Y+5)'>IOSL)
  1. D ^PSOBUILD
  1. D:'$D(PSODGCK) @$S($G(COPY):"^PSOCPPRE",1:"^PSODDPRE") ; Duplicate drug check
  1. G:$G(PSORX("DFLG")) POSTX
  1. D HD^PSODDPR2():(($Y+5)'>IOSL)
  1. I $$GET1^DIQ(50,+$G(PSODRUG("IEN")),17.5)="PSOCLO1" D CLOZ
  1. G:PSORX("DFLG") POSTX
  1. D HD^PSODDPR2():(($Y+5)'>IOSL)
  1. W !,"Now doing allergy checks. Please wait...",! H 1
  1. S PSONOAL="" D ALLERGY^PSOORUT2 D:PSONOAL'="" NOALRGY K PSONOAL
  1. D HD^PSODDPR2():(($Y+5)'>IOSL)
  1. I '$G(PSODGCKX) D ^PSODGAL1 K PSORX("INTERVENE")
  1. G:PSORX("DFLG")!$G(PSOQUIT) POSTX
  1. ;This is the allergy check for profile drugs CK action
  1. I $D(PSODGCK),$D(PSOSD) D PRFLP^PSOUTL
  1. G:$G(PSORX("DFLG")) POSTX ;pso*7*412
  1. G:$G(PSOSPRNW)&($G(PSORENW("DFLG"))) POSTX ;speed renew
  1. ;aminoglycoside
  1. N AOC,CROCPFLG S CROCPFLG=0
  1. D HD^PSODDPR2():(($Y+5)'>IOSL)
  1. S AOC=$$AOC^OROCAPI(PSODFN,$P(PSODRUG("NDF"),"A",2)) I $P(AOC,"^",4)]"" D
  1. .S CROCPFLG=1
  1. .W !!,"***Aminoglycoside Ordered***",!!
  1. .K ^UTILITY($J,"W") S DIWL=1,DIWR=78,DIWF="" S X=$P(AOC,"^",4) D ^DIWP
  1. .W ! F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W ?2,^UTILITY($J,"W",1,ZX,0),! D HD^PSODDPR2():(($Y+5)'>IOSL)
  1. .K ^UTILITY($J,"W")
  1. .S ^TMP("PSODAOC",$J,"CPRS",$P(AOC,"^",2),0)=PSODRUG("IEN")_"^"_$P(AOC,"^",4)
  1. .W !
  1. D HD^PSODDPR2():(($Y+5)'>IOSL)
  1. ;dangerous meds for pat >64
  1. I $G(PSODRUG("OI")) D
  1. .N OI,OIR S OI=$$OITM^ORX8(PSODRUG("OI"),"99PSP") Q:'OI
  1. .S OIR=$$DOC^OROCAPI(PSODFN,OI) I $P(OIR,"^",4)]"" D
  1. ..S CROCPFLG=1
  1. ..D HD^PSODDPR2():(($Y+5)'>IOSL) W !!,"***Dangerous Meds for Patient >64***",!! S DFN=PSODFN D DEM^VADPT
  1. ..K ^UTILITY($J,"W") S DIWL=1,DIWR=78,DIWF="" S X=$P(OIR,"^",4) D ^DIWP
  1. ..F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W ?2,^UTILITY($J,"W",1,ZX,0),! D HD^PSODDPR2():(($Y+5)'>IOSL)
  1. ..K ^UTILITY($J,"W")
  1. ..S ^TMP("PSODAOC",$J,"CPRS",$P(OIR,"^",2),0)=PSODRUG("IEN")_"^"_$P(OIR,"^",4)
  1. ..W !
  1. D HD^PSODDPR2():(($Y+5)'>IOSL)
  1. ;metformin lab results
  1. N GOC S GOC=$$GOC^OROCAPI(PSODFN,PSODRUG("NAME")) I $P(GOC,"^",4)]"" D
  1. .S CROCPFLG=1
  1. .W !!,"***Metformin Lab Results***",!!
  1. .K ^UTILITY($J,"W") S DIWL=1,DIWR=78,DIWF="" S X=$P(GOC,"^",4) D ^DIWP
  1. .F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W ?2,^UTILITY($J,"W",1,ZX,0),! D HD^PSODDPR2():(($Y+5)'>IOSL)
  1. .K ^UTILITY($J,"W")
  1. .S ^TMP("PSODAOC",$J,"CPRS",$P(GOC,"^",2),0)=PSODRUG("IEN")_"^"_$P(GOC,"^",4)
  1. .W !
  1. D HD^PSODDPR2():(($Y+5)'>IOSL)
  1. ;clinical reminder oc
  1. D:'$G(PSONCROC) CK^PSOCROC K CROCPFLG I $G(PSORX("DFLG")) Q
  1. K DIWF,DIWL,DIWR,ZX,DFN,CROCPFLG
  1. I $G(PSODRUG("DEA"))["S"!($E($G(PSODRUG("VA CLASS")),1,2)="XA"),'$G(PSODGCK) D G POSTX ;stops if drug is supply
  1. .W !,"Now Processing Enhanced Order Checks! Please wait...",! H 1
  1. ;enhanced OC
  1. D HD^PSODDPR2():(($Y+5)'>IOSL)
  1. W ! D @$S($G(COPY):"OBX^PSOCPPRE",1:"OBX^PSODDPRE") ; Set PSORX("DFLG")=1 if process to stop new enhanced order checks
  1. POSTX ;
  1. K IT,^TMP($J,"DI"),PSORX("INTERVENE"),DA,^TMP($J,"PSODRDI"),ZDGDG,ZTHER,^TMP($J,"DI"_PSODFN),PSZZQUIT
  1. I '$G(PSORXED),'$G(PSOREINS) K PSOQUIT
  1. Q
  1. ;
  1. EOJ ;
  1. K PSODRG
  1. Q
  1. WAIT ;
  1. K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue..." W !
  1. D ^DIR K DIRUT,DUOUT,DIR,X,Y
  1. Q
  1. ;
  1. CLOZ ;
  1. S ANQRTN=$$GET1^DIQ(50,+$G(PSODRUG("IEN")),17.5),ANQX=0
  1. S P(5)=PSODRUG("IEN"),DFN=PSODFN,X=ANQRTN
  1. X ^%ZOSF("TEST") I D ^PSOCLO1 S:$G(ANQX) PSORX("DFLG")=1
  1. K P(5),ANQRTN,ANQX,X,DFN
  1. Q
  1. ;
  1. EN(DRG) ;returns lab test identified for clozapine order checking
  1. K LAB I $$GET1^DIQ(50,+$G(DRG),17.5)'="PSOCLO1" S LAB("NOT")=0 Q
  1. N LABARR D LIST^DIC(50.02,","_DRG_",","2;3","I",,,,,,,"LABARR")
  1. I +LABARR("DILIST",0)'=2 S LAB("BAD TEST")=0 K CNT Q
  1. K CNT F I=1:1 Q:'$D(LABARR("DILIST",2,I)) D
  1. .S LABT=$S(LABARR("DILIST","ID",I,3)=1:"WBC",1:"ANC")
  1. .S LAB(LABT)=LABARR("DILIST",1,I)_"^"_LABARR("DILIST","ID",I,2)_"^"_LABARR("DILIST","ID",I,3)
  1. K LABT,I
  1. Q
  1. NOALRGY ;
  1. D HD^PSODDPR2():(($Y+5)'>IOSL)
  1. N DIR S DIR(0)="SA^1:YES;0:NO"
  1. I $D(^TMP($J,"PSOINTERVENE",+PSODFN)) D Q
  1. .S DIR("A")="No Allergy Assessment - Do you want to duplicate Intervention?: ",DIR("B")="Yes"
  1. .D ^DIR
  1. .I 'Y D Q
  1. ..I Y=0 D ^PSORXI Q
  1. ..S PSORX("DFLG")=1
  1. .D DUPINV^PSORXI
  1. W $C(7),!,"There is no allergy assessment on file for this patient."
  1. W !,"You will be prompted to intervene if you continue with this prescription"
  1. I $D(PSODGCK) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue..." D ^DIR K DIR
  1. Q:$D(PSODGCK)
  1. N DUOUT,DTOUT,RXIEN,RXSTA ;*398
  1. S DIR("A")="Do you want to Continue?: ",DIR("B")="N" D ^DIR
  1. I 'Y!($D(DUOUT))!($D(DTOUT)) D Q ;*398 - Exit/Timeout
  1. .I $D(PSONV) S PSZZQUIT=1 Q
  1. .S PSORX("DFLG")=1
  1. .I '$O(PSCAN(0)) Q ;*398 - Array has Rx IEN
  1. .I $G(REA)'="R" Q ;*398 - Reinstate only
  1. .S RXIEN=+$G(PSCAN(RX)) I 'RXIEN Q ;*398 - Get Rx IEN
  1. .S RXSTA=$$GET1^DIQ(52,RXIEN,100,"I") ;*398 - Get status
  1. .I RXSTA=12 Q ;*398 - Correct status
  1. .S DIE="^PSRX(",DA=RXIEN,DR="100///12" ;*398 - Discontinued
  1. .D ^DIE ;*398 - Update Rx file
  1. I $D(PSONV) S PSORX("INTERVENE")=0 D EN1^PSORXI(PSONV) Q
  1. D ^PSORXI
  1. Q
  1. ;
  1. WRAPTEXT(TEXT,LIMIT,CSPACES) ;Wrap text util copied in from a PSO routine originally *524
  1. ;;FUNCTION TO DISPLAY (WRITE) TEXT WRAPPED TO A CERTAIN COLUMN LENGTH
  1. ;;DEFAULT=74 CHARACTERS WITH NO SPACES IN FRONT
  1. N WORDS,COUNT,LINE,NEXTWORD
  1. Q:$G(TEXT)']"" ""
  1. S LIMIT=$G(LIMIT,74)
  1. S CSPACES=$S($G(CSPACES):CSPACES,1:0)
  1. S WORDS=$L(TEXT," ")
  1. W !,$$REPEAT^XLFSTR(" ",CSPACES)
  1. F COUNT=1:1:WORDS D
  1. . S NEXTWORD=$P(TEXT," ",COUNT)
  1. . Q:NEXTWORD="" ;TO REMOVE LEADING OR DOUBLE SPACES
  1. . S LINE=$G(LINE)_NEXTWORD_" "
  1. . I $L($G(LINE))>LIMIT W !,$$REPEAT^XLFSTR(" ",CSPACES) K LINE
  1. . W NEXTWORD_" "
  1. Q