PSODDPR5 ;BIR/SAB - displays OP/rdi/pending/nva orders ;08/23/17 19:46
;;7.0;OUTPATIENT PHARMACY;**251,375,379,390,372,416,438,411,484,441**;DEC 1997;Build 208
;External reference to ^PSDRUG( supported by DBIA 4846
;External reference to ^PS(50.606 supported by DBIA 2174
;External reference to ^PS(50.7 supported by DBIA 2223
;External reference to ^PS(55 supported by DBIA 2228
;
EXC ;displays order check exceptions
N Q,CT,ONT,OT,ON,TD,ERRTY,OP,OPP,ZEXC,ZREA,X,DIWL,DIWR,DIWF,PSOWROTE,ZX
I ($Y+5)'>IOSL D HD^PSODDPR2() Q:$G(PSODLQT) ;W @IOF
S (CT,Q)=0,ONT=""
F S ONT=$O(^TMP($J,LIST,"OUT","EXCEPTIONS",ONT)) Q:ONT="" F S CT=$O(^TMP($J,LIST,"OUT","EXCEPTIONS",ONT,CT)) Q:'CT D
.S ZEXC=^TMP($J,LIST,"OUT","EXCEPTIONS",ONT,CT),ZREA=$P(^TMP($J,LIST,"OUT","EXCEPTIONS",ONT,CT),"^",10)
.S OT=$P(ONT,";"),ON=$P(ONT,";",2),OP=$P(ONT,";",3),OPP=OT_";"_ON_";"_OP
.I '$D(PSODGCK),'$D(PSSDGCK),OT="Z",ZREA="Drug not matched to NDF"!($P(^TMP($J,LIST,"OUT","EXCEPTIONS",ONT,CT),"^",7)["manual check") S PSODRUG("BAD",PSODRUG("IEN"))=1
.Q:$G(^TMP($J,"PSEXC","OUT",OPP))
.S Q=Q+1,ERRTY=$S(OT="R":"RDI",OT="N":"Non-VA",OT="P":"Pending",OT="O":"Rx",1:"")
.K ^UTILITY($J,"W") S DIWL=1,DIWR=75,DIWF=""
.W ! S X=$P(^TMP($J,LIST,"OUT","EXCEPTIONS",ONT,CT),"^",7) D ^DIWP
.F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W !,^UTILITY($J,"W",1,ZX,0) S PSOWROTE=1
.I $D(PSODGCK)!$D(PSSDGCK) K DIR S DIR(0)="E",DIR("A")="Press Return to Continue..." W ! D ^DIR K DIR W @IOF
.S:OT'="Z" ^TMP($J,"PSEXC","OUT",OPP)=1,PSOWROTE=1
.Q:ZREA=""
.K ^UTILITY($J,"W") S DIWL=1,DIWR=75,DIWF=""
.S X=" Reason(s): "_ZREA D ^DIWP
.F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W !,^UTILITY($J,"W",1,ZX,0) S PSOWROTE=1
.K ^UTILITY($J,"W"),X,DIWL,DIWR,DIWF
.D:$O(^TMP($J,LIST,"OUT","EXCEPTIONS",ONT,CT)) HD^PSODDPR2() Q:$G(PSODLQT)
W !! I $G(PSOWROTE) K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR S:($D(DTOUT))!($D(DUOUT)) PSODLQT=1,PSORX("DFLG")=1 W ! K DIR,X,Y I ($Y+5)>IOSL W @IOF
Q
NOCAN ;shows duplicate therapeutic when cancel duplicate class parameter is et to 'no'
K ^UTILITY($J,"W"),DDTH,DOCPL S DIWL=1,DIWR=78,DIWF="",(CT,SUB)=0 K TCT,TCTP,TCTL,TCTI,ZZQ,ZHDR
F S CT=$O(^TMP($J,LIST,"OUT","THERAPY",CT)) Q:'CT F S SUB=$O(^TMP($J,LIST,"OUT","THERAPY",CT,"DRUGS",SUB)) Q:'SUB D
.S ON=$P(^TMP($J,LIST,"OUT","THERAPY",CT,"DRUGS",SUB),"^"),PDRG=$P(^(SUB),"^",3),RXREC=$P(ON,";",2)
.I $G(PSODCTH(ON)) Q
.I $P(ON,";")="Z" Q
.I $P(ON,";")="N",$G(^TMP($J,"PSONVADD",RXREC,0)) Q
.I $P(ON,";")="R",$G(^TMP($J,"PSORMDD",RXREC,0)) Q
.I $P(ON,";")="O",$G(^TMP("PSORXDC",$J,RXREC,0)) Q
.I $P(ON,";")="P",$G(^TMP("PSORXDC",$J,RXREC,0)) Q
.I $P(ON,";")="O",$G(^TMP("PSORXDD",$J,RXREC,0)) Q
.I '$G(ZHDR) D HD^PSODDPR2():(($Y+5)'>IOSL) Q:$G(PSODLQT) W !,PSONULN,!,"*** THERAPEUTIC DUPLICATION(S) *** "_PSODRUG("NAME")_" with",! S ZHDR=1
Q:'$G(ZHDR) Q:$G(PSODLQT)
N ST,STA,STAT,ORT K DOCPL
S (SUB,CT)=0 F S CT=$O(^TMP($J,LIST,"OUT","THERAPY",CT)) Q:'CT F S SUB=$O(^TMP($J,LIST,"OUT","THERAPY",CT,"DRUGS",SUB)) Q:'SUB D DUPCL K DDTH
D DUPCP
Q
DUPCL ;
S ON=$P(^TMP($J,LIST,"OUT","THERAPY",CT,"DRUGS",SUB),"^"),PDRG=$P(^(SUB),"^",3),RXREC=$P(ON,";",2)
I $P(ON,";")="Z" Q
I $P(ON,";")="N",$G(^TMP($J,"PSONVADD",RXREC,0)) Q
I $P(ON,";")="R",$G(^TMP($J,"PSORMDD",RXREC,0)) Q
I $P(ON,";")="O",$G(^TMP("PSORXDC",$J,RXREC,0)) Q
I $P(ON,";")="P",$G(^TMP("PSORXDC",$J,RXREC,0)) Q
I $P(ON,";")="O",$G(^TMP("PSORXDD",$J,RXREC,0)) Q
S ORT=$S($P(ON,";")="N":4,$P(ON,";")="P":3,$P(ON,";")="R":2,1:1)
S DOCPL(ORT,ON)=""
Q
DUPCP D HD^PSODDPR2():(($Y+5)'>IOSL) S ORT=0,ON="" F S ORT=$O(DOCPL(ORT)) Q:'ORT!$G(PSODLQT) F S ON=$O(DOCPL(ORT,ON)) Q:ON=""!$G(PSODLQT) D
.I $P(ON,";")="O" D
..D HD^PSODDPR2():(($Y+5)'>IOSL) Q:$G(PSODLQT) S ST=$P(^PSRX($P(ON,";",2),"STA"),"^")+1
..S STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^^EXPIRED^DISCONTINUED^^DISCONTINUED BY PROVIDER^DISCONTINUE EDIT^PROVIDER HOLD"
..S STAT=$P(STA,"^",ST) D ;441 PAPI
...I ST=1,$G(^PSRX($P(ON,";",2),"PARK")) S STAT="PARKED"
...W !?2,"Local Rx #"_$P(^PSRX($P(ON,";",2),0),"^")_" ("_STAT_") for "_$P(^PSDRUG($P(^PSRX($P(ON,";",2),0),"^",6),0),"^")
.I $P(ON,";")="P" D
..D HD^PSODDPR2():(($Y+5)'>IOSL) Q:$G(PSODLQT)
..N DNM,DUPRX0 S RXREC=$P(ON,";",2),DNM=$P(^PS(52.41,RXREC,0),"^",9)
..S DUPRX0=^PS(52.41,RXREC,0)
..W !?2,"Pending Order for "
..I '$P(DUPRX0,"^",9) W $P(^PS(50.7,$P(DUPRX0,"^",8),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")
..E W $P(^PSDRUG($P(DUPRX0,"^",9),0),"^")
.I $P(ON,";")="R" N RXDAT D
..D HD^PSODDPR2():(($Y+5)'>IOSL) Q:$G(PSODLQT)
..N RDIRX S RXDAT=^TMP($J,LIST,"OUT","REMOTE",$P(ON,";",2))
..S RDIRX=$P(RXDAT,"^",5) D HD^PSODDPR2():(($Y+5)'>IOSL) Q:$G(PSODLQT) W !?2,"Remote Rx #"_RDIRX_" ("_$P(RXDAT,"^",4)_") for "_$P(RXDAT,"^",3)
.I $P(ON,";")="N" D
..Q:'$D(^PS(55,PSODFN,"NVA",$P(ON,";",2),0))
..S DUPRX0=^PS(55,PSODFN,"NVA",$P(ON,";",2),0) N NVAQ
..D HD^PSODDPR2():(($Y+5)'>IOSL) Q:$G(PSODLQT)
..W !?2,"Non-VA Med for "
..I '$P(DUPRX0,"^",2) W $P(^PS(50.7,$P(DUPRX0,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")
..E W $P(^PSDRUG($P(DUPRX0,"^",2),0),"^")
.S DDTH(ON)=1
D HD^PSODDPR2():(($Y+5)'>IOSL) Q:$G(PSODLQT)
D CLASSES^PSODDPR3
D HD^PSODDPR2(0,1) Q:$G(PSODLQT)
Q
REMOTE ;backdoor RDI
Q:$G(PSODLQT)
N INDD,DO,P3,RDIDNAM,RDIVUID,RDITMP,PSORDI,SEQN,ZI
S PSORDI=0 F S PSORDI=$O(^TMP($J,LIST,"OUT","REMOTE",PSORDI)) Q:'PSORDI!$G(PSODLQT) S RDITMP=^(PSORDI) D K PSOSEQN
.I $P(RDITMP,"^",2)="" Q
.S RDIVUID=$P(RDITMP,"^",2),RDIDNAM=$P(RDITMP,"^",3)
.I $O(PDRG(0)) F ZI=0:0 S ZI=$O(PDRG(ZI)) Q:'ZI I $P(^PSDRUG($P(PDRG(ZI),"^"),0),"^")=RDIDNAM S INDD=+$G(INDD)+1,^TMP($J,"DD",INDD,0)=$P(PDRG(ZI),"^")_"^"_RDIDNAM_"^^"_PSORDI_"Z;O"
.S DO=$G(DO)+1 D GETIREF^XTID(50.68,.01,RDIVUID,"PSOSEQN",1) I 'PSOSEQN S ^TMP($J,LIST,"IN","PROFILE","R;"_PSORDI_";PROFILE;"_DO)=0_"^"_RDIVUID_"^0^"_RDIDNAM_"^^" Q
.S SEQN="" S SEQN=$O(PSOSEQN(50.68,.01,SEQN)) Q:SEQN=""
.S P3=+SEQN,SEQN=$P($$PROD0^PSNAPIS(,P3),"^",7)
.S ^TMP($J,LIST,"IN","PROFILE","R;"_PSORDI_";PROFILE;"_DO)=SEQN_"^"_RDIVUID_"^0^"_RDIDNAM_"^^"
Q
NSRT ;sort of drug interactions ; called by psoddpr2
;Q:$G(PSODLQT)
N SV,SEV,STOP,TYP,CNT,CHK,DRG,ON,CT,ZOT,PSOVAG,PSODD,COUNT,NSRT,NSRT2,II,ZZDGDG3 S COUNT=0,(SV,DRG,ON,CT,PSOVAG)=""
F S SV=$O(^TMP($J,LIST,"OUT","DRUGDRUG",SV)) Q:SV=""!$G(PSODLQT) D Q:$G(PSORX("DFLG"))
.F S DRG=$O(^TMP($J,LIST,"OUT","DRUGDRUG",SV,DRG)) Q:DRG=""!$G(PSODLQT) F S ON=$O(^TMP($J,LIST,"OUT","DRUGDRUG",SV,DRG,ON)) Q:ON=""!$G(PSODLQT) F S CT=$O(^TMP($J,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT)) Q:'CT!$G(PSODLQT) D
..I $P(ON,";")'="Z",$P(ON,";")="O",$P(^PSRX($P(ON,";",2),"STA"),"^")>5,$P(^PSRX($P(ON,";",2),"STA"),"^")'=16 Q
..I $P(ON,";")'="Z",$P(ON,";")="R" D RVAGEN Q
..I $P(ON,";")'="Z",$P(ON,";")="P",'$P($G(^PS(52.41,$P(ON,";",2),0)),"^",9) S PSORDIT=$P($G(^PS(52.41,$P(ON,";",2),0)),"^",8) D:$G(PSORDIT) DVAGEN ;Q 163815
..I $P(ON,";")'="Z",$P(ON,";")="N",'$P($G(^PS(55,PSODFN,"NVA",$P(ON,";",2),0)),"^",2) S PSORDIT=$P($G(^PS(55,PSODFN,"NVA",$P(ON,";",2),0)),"^") D:$G(PSORDIT) DVAGEN ;Q ;*438
..S PSODD=$O(^PSDRUG("B",DRG,0)) D:PSODD'="" VAGEN^PSODDPR3(PSODD)
..S:PSOVAG="" PSOVAG=DRG
..S ZOT=$S($P(ON,";")["C":1,$P(ON,";")="O":2,$P(ON,";")="R":3,$P(ON,";")="P":4,1:5)
..S ZDGDG(SV,ZOT,PSOVAG,DRG)=ON_"^"_CT,ZZDGDG3(SV,PSOVAG,DRG)=""
..I ZOT=1 S PSOCLNS(SV,PSOVAG,DRG,ON)=CT
..I '$D(NSRT(SV,PSOVAG)) S NSRT(SV,PSOVAG)=ZOT
..E S $P(NSRT(SV,PSOVAG),"^",1)=$P(NSRT(SV,PSOVAG),"^",1)_","_ZOT
;resort of zdgdg
K ZZDGDG S (SEV,STOP,PSOVAG,TYP,ON)="",CNT=0
F J=1:1:5 F S SEV=$O(NSRT(SEV)) Q:SEV="" F I=1:1:5 F S PSOVAG=$O(NSRT(SEV,PSOVAG)) Q:PSOVAG="" D
.S TYP="",TYP=","_$P(NSRT(SEV,PSOVAG),"^",1)_","
.Q:TYP'[(","_J_",")
.S STOP=0 F CHK=1:1:5 I TYP[(","_CHK_",")&(CHK<J) S STOP=1
.Q:STOP
.S CNT=CNT+1 F II=J:1:5 S TYP=I I $D(ZDGDG(SEV,TYP)) D S2(SEV,TYP,PSOVAG,CNT)
D DGSORT^PSODDPR2
K NSRT,J,F,I,ZDGDG,COUNT,CNT
Q
;print order sort
S2(SEV,TYP,PSOVAG,CNT) ;
N PSONAM,COUNT2 S (PSONAM)="",COUNT2=0
F S PSONAM=$O(ZDGDG(SEV,TYP,PSOVAG,PSONAM)) Q:PSONAM="" S COUNT2=COUNT2+1 D
.S ZZDGDG(SEV,CNT,TYP,PSOVAG,PSONAM)=ZDGDG(SEV,TYP,PSOVAG,PSONAM)
.S ZZDGCK(SEV,CNT,TYP,PSOVAG,PSONAM)=ZDGDG(SEV,TYP,PSOVAG,PSONAM)
Q
;
NSRT1 ;sort out dc'd drug therapies local and remote rxs
N RXN,SUB S (SUB,CT)=0 K PSODCTH
F S CT=$O(^TMP($J,LIST,"OUT","THERAPY",CT)) Q:'CT F S SUB=$O(^TMP($J,LIST,"OUT","THERAPY",CT,"DRUGS",SUB)) Q:'SUB D
.S ON=$P(^TMP($J,LIST,"OUT","THERAPY",CT,"DRUGS",SUB),"^")
.I $P(ON,";")="O",$P($G(^PSRX($P(ON,";",2),3)),"^",5) D Q
..S RXN=$P(ON,";",2),X1=$P($G(^PSRX($P(ON,";",2),3)),"^",5),X2=(+$P(^PSRX($P(ON,";",2),0),"^",8)+7)
..D C^%DTC I X<DT S PSODCTH(ON)=1 K X,Y,X1,X2
.I $P(ON,";")="R",$P($G(^TMP($J,LIST,"OUT","REMOTE",$P(ON,";",2))),"^",4)["DISC" D
..S RXN=$P(ON,";",2) K X,Y,X1,X2
..S X=$P(^TMP($J,LIST,"OUT","REMOTE",RXN),"^",6) D ^%DT S X1=Y,X2=(+$P(^TMP($J,LIST,"OUT","REMOTE",RXN),"^",7)+7)
..D C^%DTC I X<DT S PSODCTH(ON)=1 K X,Y,X1,X2
Q
;
RVAGEN ;va generic for remote drugs
D RVAGEN^PSODDPR4 ;*484 - ROUTINE TOO LARGE
Q
;
DVAGEN ;va generic for non-va/pending meds
S PSI=0 N PSID,PSODD,PSOVAG
F S PSI=$O(^PSDRUG("ASP",PSORDIT,PSI)) Q:'PSI!($G(PSID)'="") I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["X":0,1:1) S PSID=$P($G(^PSDRUG(PSI,0)),"^")
I PSI="" S PSI=0 F S PSI=$O(^PSDRUG("ASP",PSORDIT,PSI)) Q:'PSI!($G(PSID)'="") I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) S PSID=$P($G(^PSDRUG(PSI,0)),"^")
I PSI="" S PSI=0 F S PSI=$O(^PSDRUG("ASP",PSORDIT,PSI)) Q:'PSI!($G(PSID)'="") I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["U":0,1:1) S PSID=$P($G(^PSDRUG(PSI,0)),"^")
I PSI="" S PSI=0 F S PSI=$O(^PSDRUG("ASP",PSORDIT,PSI)) Q:'PSI!($G(PSID)'="") I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["I":0,1:1) S PSID=$P($G(^PSDRUG(PSI,0)),"^")
I PSI="" S PSI=0 F S PSI=$O(^PSDRUG("ASP",PSORDIT,PSI)) Q:'PSI!($G(PSID)'="") I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S('$L($P($G(^PSDRUG(PSI,2)),"^",3)):0,1:1) S PSID=$P($G(^PSDRUG(PSI,0)),"^")
I PSI="" S PSI=0 F S PSI=$O(^PSDRUG("ASP",PSORDIT,PSI)) Q:'PSI!($G(PSID)'="") I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($L($P($G(^PSDRUG(PSI,2)),"^",3)):0,1:1) S PSID=$P($G(^PSDRUG(PSI,0)),"^")
Q:$G(PSID)']""
S PSODD=$O(^PSDRUG("B",PSID,0)) D VAGEN^PSODDPR3(PSODD)
Q:$G(PSOVAG)']""
S ZOT=$S($P(ON,";")="O":1,$P(ON,";")="R":2,$P(ON,";")="P":3,1:4),ZDGDG(SV,ZOT,PSOVAG,DRG)=ON_"^"_CT,ZZDGDG3(SV,PSOVAG,DRG)="",COUNT=COUNT+1
K PSI,PSID,PSORDIT,PSODD,PSOVAG
Q
;
INT ;
I $G(PSOVORD),$P(PSOINTV,"^")=1 D Q
.K DIR,DTOUT,DIRUT,DIROUT,DUOUT N DA
.W ! S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Continue? ",DIR("B")="Y" D ^DIR S:($D(DTOUT))!($D(DUOUT))!($G(DIRUT)) PSODLQT=1,PSORX("DFLG")=1 Q:$G(PSODLQT)
.K DIR,DTOUT,DIRUT,DIROUT,DUOUT
.I 'Y S PSODLQT=1,PSORX("DFLG")=1 Q
.S DA=PSONV,RXREC=DA,RX=$G(^PSRX(RXREC,0)),PSORX("INTERVENE")=1
.D:'$D(PSODGCK) CRI^PSODGDG1
.I $G(OLDDA) S DA=OLDDA K OLDDA
Q:$G(PSODLQT)!($G(PSORX("DFLG")))
I '$D(PSODGCK),$P(PSOINTV,"^") S IT=$P(PSOINTV,"^"),ON=$P(PSOINTV,"^",2) D ^PSODGDGP K DIR S IT=$P(PSOINTV,"^")
Q
;
DGCK ;CK - Drug check option at patient profile
I '$D(PSOSD) D FULL^VALM1 D CKMSG G DGCKQ
N PSODGCKX
S (PSODGCK,PSONCROC)=1
D FULL^VALM1
D PSOCK^PSOUTL
K DIR S DIR(0)="E",DIR("A")="Press Return to Continue..." W ! D ^DIR K DIR W @IOF,!
D SELECT
I $G(PSONEW("DFLG"))=1!'$D(PSOSD) W ! G DGCKQ
D SET^PSODRG
DGCKNP D POST^PSODRG
DGCKQ S VALMBCK="R"
K PSODGCK,PSODGCKX,MON,PSONEW("DFLG"),PSORX("DFLG"),PSOIENID,PSOGCNPT,PSOGCNID,PSONDFID,DGCKDUPF,PSONCROC
Q
;
GCN(PSOIENID) ;Return 0 for not matched, 1 for matched with no GCNSEQNO, 1^1 for matched with a GCNSEQNO
N PSONDFID,PSOGCNPT,PSOGCNID
S PSONDFID=$P($G(^PSDRUG(PSOIENID,"ND")),"^"),PSOGCNPT=$P($G(^PSDRUG(PSOIENID,"ND")),"^",3)
I 'PSONDFID!('PSOGCNPT) Q 0
S PSOGCNID=$$PROD0^PSNAPIS(PSONDFID,PSOGCNPT)
I $P(PSOGCNID,"^",7) Q PSOIENID_";"_PSONDFID_";"_$P(PSOGCNID,"^",7)
Q PSOIENID_";"_PSONDFID
;
PKGFLG(PKF1) ;Return 0 for not in range of acceptable package flags, 1 for within range
I $S(PKF1["O":1,1:0) Q 1
I $S(PKF1["X":1,1:0) Q 1
Q 0
;
SELECT ;
N PSODGCKD S PSODGCKD=0 K:'$G(PSORXED) CLOZPAT
K IT,DIC,X,Y,PSODRUG("TRADE NAME"),PSODRUG("NDC"),PSODRUG("DAW"),PSODRUG("BAD") S:$G(POERR)&($P($G(OR0),"^",9)) Y=$P(^PSDRUG($P(OR0,"^",9),0),"^")
I $G(PSODRUG("IEN"))]"",'$D(PSODGCK) S Y=PSODRUG("NAME"),PSONEW("OLD VAL")=PSODRUG("IEN")
W !,"DRUG: " R X:$S($D(DTIME):DTIME,1:300) I '$T S DTOUT=1
I PSODGCK,X="",PSOSD<2 D CKMSG S PSONEW("DFLG")=1 G SELECTX
S:X="" PSODGCKX=1
I X="",$G(Y)]"" S:Y X=Y S:'X X=$G(PSODRUG("IEN")) S:X X="`"_X
I X="",$D(PSOSD) S X=$O(PSOSD($O(PSOSD("")),"")),PSODGCKD=1
I X="",'$D(PSOSD) D Q
.W !!,"Now Processing Enhanced Order Checks! Please wait..." H 1
.W !!,"No Order Check Warnings Found",! K DIR S DIR("A")="Press Return to continue",DIR(0)="E",DIR("?")="Press Return to continue" D ^DIR K DIR
I X?1."?" W !!,"Answer with DRUG NUMBER, or GENERIC NAME, or VA PRODUCT NAME, or",!,"NATIONAL DRUG CLASS, or SYNONYM" G SELECT
I $G(PSORXED),X["^" S PSORXED("DFLG")=1 G SELECTX
I X="^"!(X["^^")!($D(DTOUT)) S PSONEW("DFLG")=1 G SELECTX
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
S DIC=50,DIC(0)="MZV",D="B^C^VAPN^VAC"
I 'PSODGCKD S DIC=50,DIC(0)="EMQZVT",DIC("T")="",D="B^C^VAPN^VAC"
I 'PSODGCKD S DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$$GCN^PSODDPR5(+Y),$$PKGFLG^PSODDPR5($P($G(^PSDRUG(+Y,2)),""^"",3)),$D(^PSDRUG(""ASP"",+$G(^(2)),+Y))"
D MIX^DIC1 K DIC,PKF1,D
I $$PSOSUPCK^PSOUTL(+Y) G SELECT
S (DGCKSTA,DGCKDNM)=""
I '$G(PSODGCKX),$D(PSOSD) F S DGCKSTA=$O(PSOSD(DGCKSTA)) Q:DGCKSTA=""!$G(DGCKDUPF) F S DGCKDNM=$O(PSOSD(DGCKSTA,DGCKDNM)) Q:DGCKDNM=""!$G(DGCKDUPF) D
.I DGCKDNM=$G(Y(0,0)) D
..S DGCKDUPF=1 W !!,"Duplicate Drug in Patient profile, please select a different drug:",!
..K DIR S DIR(0)="E",DIR("A")="Press Return to Continue..." D ^DIR K DIR W @IOF
I $D(DGCKDUPF) K DGCKDUPF,PSODGCKX G SELECT
I '$D(PSOSD) D Q
.W !!,"Now Processing Enhanced Order Checks! Please wait..." H 1
.W !!,"No Order Check Warnings Found",! K DIR S DIR("A")="Press Return to continue",DIR(0)="E",DIR("?")="Press Return to continue" D ^DIR K DIR
I $D(DTOUT) S PSONEW("DFLG")=1 G SELECTX
I $D(DUOUT) K DUOUT G SELECT
I Y<0 G SELECT
S:$G(PSONEW("OLD VAL"))=+Y&('$G(PSOEDIT)) PSODRG("QFLG")=1
K PSOY S PSOY=Y,PSOY(0)=Y(0)
I $P(PSOY(0),"^")="OTHER DRUG"!($P(PSOY(0),"^")="OUTSIDE DRUG") D TRADE^PSODRG
SELECTX K X,Y,DTOUT,DUOUT,PSONEW("OLD VAL"),PSODGCKD,DGCKDNM,DGCKSTA
Q
;
CKMSG ;
W !!,"Not enough active profile drugs to perform drug check",! K DIR S DIR("A")="Press Return to continue",DIR(0)="E",DIR("?")="Press Return to continue" D ^DIR K DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODDPR5 15333 printed Apr 09, 2024@21:35:44 Page 2
PSODDPR5 ;BIR/SAB - displays OP/rdi/pending/nva orders ;08/23/17 19:46
+1 ;;7.0;OUTPATIENT PHARMACY;**251,375,379,390,372,416,438,411,484,441**;DEC 1997;Build 208
+2 ;External reference to ^PSDRUG( supported by DBIA 4846
+3 ;External reference to ^PS(50.606 supported by DBIA 2174
+4 ;External reference to ^PS(50.7 supported by DBIA 2223
+5 ;External reference to ^PS(55 supported by DBIA 2228
+6 ;
EXC ;displays order check exceptions
+1 NEW Q,CT,ONT,OT,ON,TD,ERRTY,OP,OPP,ZEXC,ZREA,X,DIWL,DIWR,DIWF,PSOWROTE,ZX
+2 ;W @IOF
IF ($Y+5)'>IOSL
DO HD^PSODDPR2()
if $GET(PSODLQT)
QUIT
+3 SET (CT,Q)=0
SET ONT=""
+4 FOR
SET ONT=$ORDER(^TMP($JOB,LIST,"OUT","EXCEPTIONS",ONT))
if ONT=""
QUIT
FOR
SET CT=$ORDER(^TMP($JOB,LIST,"OUT","EXCEPTIONS",ONT,CT))
if 'CT
QUIT
Begin DoDot:1
+5 SET ZEXC=^TMP($JOB,LIST,"OUT","EXCEPTIONS",ONT,CT)
SET ZREA=$PIECE(^TMP($JOB,LIST,"OUT","EXCEPTIONS",ONT,CT),"^",10)
+6 SET OT=$PIECE(ONT,";")
SET ON=$PIECE(ONT,";",2)
SET OP=$PIECE(ONT,";",3)
SET OPP=OT_";"_ON_";"_OP
+7 IF '$DATA(PSODGCK)
IF '$DATA(PSSDGCK)
IF OT="Z"
IF ZREA="Drug not matched to NDF"!($PIECE(^TMP($JOB,LIST,"OUT","EXCEPTIONS",ONT,CT),"^",7)["manual check")
SET PSODRUG("BAD",PSODRUG("IEN"))=1
+8 if $GET(^TMP($JOB,"PSEXC","OUT",OPP))
QUIT
+9 SET Q=Q+1
SET ERRTY=$SELECT(OT="R":"RDI",OT="N":"Non-VA",OT="P":"Pending",OT="O":"Rx",1:"")
+10 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=75
SET DIWF=""
+11 WRITE !
SET X=$PIECE(^TMP($JOB,LIST,"OUT","EXCEPTIONS",ONT,CT),"^",7)
DO ^DIWP
+12 FOR ZX=0:0
SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
if 'ZX
QUIT
WRITE !,^UTILITY($JOB,"W",1,ZX,0)
SET PSOWROTE=1
+13 IF $DATA(PSODGCK)!$DATA(PSSDGCK)
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue..."
WRITE !
DO ^DIR
KILL DIR
WRITE @IOF
+14 if OT'="Z"
SET ^TMP($JOB,"PSEXC","OUT",OPP)=1
SET PSOWROTE=1
+15 if ZREA=""
QUIT
+16 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=75
SET DIWF=""
+17 SET X=" Reason(s): "_ZREA
DO ^DIWP
+18 FOR ZX=0:0
SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
if 'ZX
QUIT
WRITE !,^UTILITY($JOB,"W",1,ZX,0)
SET PSOWROTE=1
+19 KILL ^UTILITY($JOB,"W"),X,DIWL,DIWR,DIWF
+20 if $ORDER(^TMP($JOB,LIST,"OUT","EXCEPTIONS",ONT,CT))
DO HD^PSODDPR2()
if $GET(PSODLQT)
QUIT
End DoDot:1
+21 WRITE !!
IF $GET(PSOWROTE)
KILL DIR
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
SET DIR("A")="Press Return to Continue"
DO ^DIR
if ($DATA(DTOUT))!($DATA(DUOUT))
SET PSODLQT=1
SET PSORX("DFLG")=1
WRITE !
KILL DIR,X,Y
IF ($Y+5)>IOSL
WRITE @IOF
+22 QUIT
NOCAN ;shows duplicate therapeutic when cancel duplicate class parameter is et to 'no'
+1 KILL ^UTILITY($JOB,"W"),DDTH,DOCPL
SET DIWL=1
SET DIWR=78
SET DIWF=""
SET (CT,SUB)=0
KILL TCT,TCTP,TCTL,TCTI,ZZQ,ZHDR
+2 FOR
SET CT=$ORDER(^TMP($JOB,LIST,"OUT","THERAPY",CT))
if 'CT
QUIT
FOR
SET SUB=$ORDER(^TMP($JOB,LIST,"OUT","THERAPY",CT,"DRUGS",SUB))
if 'SUB
QUIT
Begin DoDot:1
+3 SET ON=$PIECE(^TMP($JOB,LIST,"OUT","THERAPY",CT,"DRUGS",SUB),"^")
SET PDRG=$PIECE(^(SUB),"^",3)
SET RXREC=$PIECE(ON,";",2)
+4 IF $GET(PSODCTH(ON))
QUIT
+5 IF $PIECE(ON,";")="Z"
QUIT
+6 IF $PIECE(ON,";")="N"
IF $GET(^TMP($JOB,"PSONVADD",RXREC,0))
QUIT
+7 IF $PIECE(ON,";")="R"
IF $GET(^TMP($JOB,"PSORMDD",RXREC,0))
QUIT
+8 IF $PIECE(ON,";")="O"
IF $GET(^TMP("PSORXDC",$JOB,RXREC,0))
QUIT
+9 IF $PIECE(ON,";")="P"
IF $GET(^TMP("PSORXDC",$JOB,RXREC,0))
QUIT
+10 IF $PIECE(ON,";")="O"
IF $GET(^TMP("PSORXDD",$JOB,RXREC,0))
QUIT
+11 IF '$GET(ZHDR)
if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
if $GET(PSODLQT)
QUIT
WRITE !,PSONULN,!,"*** THERAPEUTIC DUPLICATION(S) *** "_PSODRUG("NAME")_" with",!
SET ZHDR=1
End DoDot:1
+12 if '$GET(ZHDR)
QUIT
if $GET(PSODLQT)
QUIT
+13 NEW ST,STA,STAT,ORT
KILL DOCPL
+14 SET (SUB,CT)=0
FOR
SET CT=$ORDER(^TMP($JOB,LIST,"OUT","THERAPY",CT))
if 'CT
QUIT
FOR
SET SUB=$ORDER(^TMP($JOB,LIST,"OUT","THERAPY",CT,"DRUGS",SUB))
if 'SUB
QUIT
DO DUPCL
KILL DDTH
+15 DO DUPCP
+16 QUIT
DUPCL ;
+1 SET ON=$PIECE(^TMP($JOB,LIST,"OUT","THERAPY",CT,"DRUGS",SUB),"^")
SET PDRG=$PIECE(^(SUB),"^",3)
SET RXREC=$PIECE(ON,";",2)
+2 IF $PIECE(ON,";")="Z"
QUIT
+3 IF $PIECE(ON,";")="N"
IF $GET(^TMP($JOB,"PSONVADD",RXREC,0))
QUIT
+4 IF $PIECE(ON,";")="R"
IF $GET(^TMP($JOB,"PSORMDD",RXREC,0))
QUIT
+5 IF $PIECE(ON,";")="O"
IF $GET(^TMP("PSORXDC",$JOB,RXREC,0))
QUIT
+6 IF $PIECE(ON,";")="P"
IF $GET(^TMP("PSORXDC",$JOB,RXREC,0))
QUIT
+7 IF $PIECE(ON,";")="O"
IF $GET(^TMP("PSORXDD",$JOB,RXREC,0))
QUIT
+8 SET ORT=$SELECT($PIECE(ON,";")="N":4,$PIECE(ON,";")="P":3,$PIECE(ON,";")="R":2,1:1)
+9 SET DOCPL(ORT,ON)=""
+10 QUIT
DUPCP if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
SET ORT=0
SET ON=""
FOR
SET ORT=$ORDER(DOCPL(ORT))
if 'ORT!$GET(PSODLQT)
QUIT
FOR
SET ON=$ORDER(DOCPL(ORT,ON))
if ON=""!$GET(PSODLQT)
QUIT
Begin DoDot:1
+1 IF $PIECE(ON,";")="O"
Begin DoDot:2
+2 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
if $GET(PSODLQT)
QUIT
SET ST=$PIECE(^PSRX($PIECE(ON,";",2),"STA"),"^")+1
+3 SET STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^^EXPIRED^DISCONTINUED^^DISCONTINUED BY PROVIDER^DISCONTINUE EDIT^PROVIDER HOLD"
+4 ;441 PAPI
SET STAT=$PIECE(STA,"^",ST)
Begin DoDot:3
+5 IF ST=1
IF $GET(^PSRX($PIECE(ON,";",2),"PARK"))
SET STAT="PARKED"
+6 WRITE !?2,"Local Rx #"_$PIECE(^PSRX($PIECE(ON,";",2),0),"^")_" ("_STAT_") for "_$PIECE(^PSDRUG($PIECE(^PSRX($PIECE(ON,";",2),0),"^",6),0),"^")
End DoDot:3
End DoDot:2
+7 IF $PIECE(ON,";")="P"
Begin DoDot:2
+8 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
if $GET(PSODLQT)
QUIT
+9 NEW DNM,DUPRX0
SET RXREC=$PIECE(ON,";",2)
SET DNM=$PIECE(^PS(52.41,RXREC,0),"^",9)
+10 SET DUPRX0=^PS(52.41,RXREC,0)
+11 WRITE !?2,"Pending Order for "
+12 IF '$PIECE(DUPRX0,"^",9)
WRITE $PIECE(^PS(50.7,$PIECE(DUPRX0,"^",8),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^")
+13 IF '$TEST
WRITE $PIECE(^PSDRUG($PIECE(DUPRX0,"^",9),0),"^")
End DoDot:2
+14 IF $PIECE(ON,";")="R"
NEW RXDAT
Begin DoDot:2
+15 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
if $GET(PSODLQT)
QUIT
+16 NEW RDIRX
SET RXDAT=^TMP($JOB,LIST,"OUT","REMOTE",$PIECE(ON,";",2))
+17 SET RDIRX=$PIECE(RXDAT,"^",5)
if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
if $GET(PSODLQT)
QUIT
WRITE !?2,"Remote Rx #"_RDIRX_" ("_$PIECE(RXDAT,"^",4)_") for "_$PIECE(RXDAT,"^",3)
End DoDot:2
+18 IF $PIECE(ON,";")="N"
Begin DoDot:2
+19 if '$DATA(^PS(55,PSODFN,"NVA",$PIECE(ON,";",2),0))
QUIT
+20 SET DUPRX0=^PS(55,PSODFN,"NVA",$PIECE(ON,";",2),0)
NEW NVAQ
+21 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
if $GET(PSODLQT)
QUIT
+22 WRITE !?2,"Non-VA Med for "
+23 IF '$PIECE(DUPRX0,"^",2)
WRITE $PIECE(^PS(50.7,$PIECE(DUPRX0,"^"),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^")
+24 IF '$TEST
WRITE $PIECE(^PSDRUG($PIECE(DUPRX0,"^",2),0),"^")
End DoDot:2
+25 SET DDTH(ON)=1
End DoDot:1
+26 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
if $GET(PSODLQT)
QUIT
+27 DO CLASSES^PSODDPR3
+28 DO HD^PSODDPR2(0,1)
if $GET(PSODLQT)
QUIT
+29 QUIT
REMOTE ;backdoor RDI
+1 if $GET(PSODLQT)
QUIT
+2 NEW INDD,DO,P3,RDIDNAM,RDIVUID,RDITMP,PSORDI,SEQN,ZI
+3 SET PSORDI=0
FOR
SET PSORDI=$ORDER(^TMP($JOB,LIST,"OUT","REMOTE",PSORDI))
if 'PSORDI!$GET(PSODLQT)
QUIT
SET RDITMP=^(PSORDI)
Begin DoDot:1
+4 IF $PIECE(RDITMP,"^",2)=""
QUIT
+5 SET RDIVUID=$PIECE(RDITMP,"^",2)
SET RDIDNAM=$PIECE(RDITMP,"^",3)
+6 IF $ORDER(PDRG(0))
FOR ZI=0:0
SET ZI=$ORDER(PDRG(ZI))
if 'ZI
QUIT
IF $PIECE(^PSDRUG($PIECE(PDRG(ZI),"^"),0),"^")=RDIDNAM
SET INDD=+$GET(INDD)+1
SET ^TMP($JOB,"DD",INDD,0)=$PIECE(PDRG(ZI),"^")_"^"_RDIDNAM_"^^"_PSORDI_"Z;O"
+7 SET DO=$GET(DO)+1
DO GETIREF^XTID(50.68,.01,RDIVUID,"PSOSEQN",1)
IF 'PSOSEQN
SET ^TMP($JOB,LIST,"IN","PROFILE","R;"_PSORDI_";PROFILE;"_DO)=0_"^"_RDIVUID_"^0^"_RDIDNAM_"^^"
QUIT
+8 SET SEQN=""
SET SEQN=$ORDER(PSOSEQN(50.68,.01,SEQN))
if SEQN=""
QUIT
+9 SET P3=+SEQN
SET SEQN=$PIECE($$PROD0^PSNAPIS(,P3),"^",7)
+10 SET ^TMP($JOB,LIST,"IN","PROFILE","R;"_PSORDI_";PROFILE;"_DO)=SEQN_"^"_RDIVUID_"^0^"_RDIDNAM_"^^"
End DoDot:1
KILL PSOSEQN
+11 QUIT
NSRT ;sort of drug interactions ; called by psoddpr2
+1 ;Q:$G(PSODLQT)
+2 NEW SV,SEV,STOP,TYP,CNT,CHK,DRG,ON,CT,ZOT,PSOVAG,PSODD,COUNT,NSRT,NSRT2,II,ZZDGDG3
SET COUNT=0
SET (SV,DRG,ON,CT,PSOVAG)=""
+3 FOR
SET SV=$ORDER(^TMP($JOB,LIST,"OUT","DRUGDRUG",SV))
if SV=""!$GET(PSODLQT)
QUIT
Begin DoDot:1
+4 FOR
SET DRG=$ORDER(^TMP($JOB,LIST,"OUT","DRUGDRUG",SV,DRG))
if DRG=""!$GET(PSODLQT)
QUIT
FOR
SET ON=$ORDER(^TMP($JOB,LIST,"OUT","DRUGDRUG",SV,DRG,ON))
if ON=""!$GET(PSODLQT)
QUIT
FOR
SET CT=$ORDER(^TMP($JOB,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT))
if 'CT!$GET(PSODLQT)
QUIT
Begin DoDot:2
+5 IF $PIECE(ON,";")'="Z"
IF $PIECE(ON,";")="O"
IF $PIECE(^PSRX($PIECE(ON,";",2),"STA"),"^")>5
IF $PIECE(^PSRX($PIECE(ON,";",2),"STA"),"^")'=16
QUIT
+6 IF $PIECE(ON,";")'="Z"
IF $PIECE(ON,";")="R"
DO RVAGEN
QUIT
+7 ;Q 163815
IF $PIECE(ON,";")'="Z"
IF $PIECE(ON,";")="P"
IF '$PIECE($GET(^PS(52.41,$PIECE(ON,";",2),0)),"^",9)
SET PSORDIT=$PIECE($GET(^PS(52.41,$PIECE(ON,";",2),0)),"^",8)
if $GET(PSORDIT)
DO DVAGEN
+8 ;Q ;*438
IF $PIECE(ON,";")'="Z"
IF $PIECE(ON,";")="N"
IF '$PIECE($GET(^PS(55,PSODFN,"NVA",$PIECE(ON,";",2),0)),"^",2)
SET PSORDIT=$PIECE($GET(^PS(55,PSODFN,"NVA",$PIECE(ON,";",2),0)),"^")
if $GET(PSORDIT)
DO DVAGEN
+9 SET PSODD=$ORDER(^PSDRUG("B",DRG,0))
if PSODD'=""
DO VAGEN^PSODDPR3(PSODD)
+10 if PSOVAG=""
SET PSOVAG=DRG
+11 SET ZOT=$SELECT($PIECE(ON,";")["C":1,$PIECE(ON,";")="O":2,$PIECE(ON,";")="R":3,$PIECE(ON,";")="P":4,1:5)
+12 SET ZDGDG(SV,ZOT,PSOVAG,DRG)=ON_"^"_CT
SET ZZDGDG3(SV,PSOVAG,DRG)=""
+13 IF ZOT=1
SET PSOCLNS(SV,PSOVAG,DRG,ON)=CT
+14 IF '$DATA(NSRT(SV,PSOVAG))
SET NSRT(SV,PSOVAG)=ZOT
+15 IF '$TEST
SET $PIECE(NSRT(SV,PSOVAG),"^",1)=$PIECE(NSRT(SV,PSOVAG),"^",1)_","_ZOT
End DoDot:2
End DoDot:1
if $GET(PSORX("DFLG"))
QUIT
+16 ;resort of zdgdg
+17 KILL ZZDGDG
SET (SEV,STOP,PSOVAG,TYP,ON)=""
SET CNT=0
+18 FOR J=1:1:5
FOR
SET SEV=$ORDER(NSRT(SEV))
if SEV=""
QUIT
FOR I=1:1:5
FOR
SET PSOVAG=$ORDER(NSRT(SEV,PSOVAG))
if PSOVAG=""
QUIT
Begin DoDot:1
+19 SET TYP=""
SET TYP=","_$PIECE(NSRT(SEV,PSOVAG),"^",1)_","
+20 if TYP'[(","_J_",")
QUIT
+21 SET STOP=0
FOR CHK=1:1:5
IF TYP[(","_CHK_",")&(CHK<J)
SET STOP=1
+22 if STOP
QUIT
+23 SET CNT=CNT+1
FOR II=J:1:5
SET TYP=I
IF $DATA(ZDGDG(SEV,TYP))
DO S2(SEV,TYP,PSOVAG,CNT)
End DoDot:1
+24 DO DGSORT^PSODDPR2
+25 KILL NSRT,J,F,I,ZDGDG,COUNT,CNT
+26 QUIT
+27 ;print order sort
S2(SEV,TYP,PSOVAG,CNT) ;
+1 NEW PSONAM,COUNT2
SET (PSONAM)=""
SET COUNT2=0
+2 FOR
SET PSONAM=$ORDER(ZDGDG(SEV,TYP,PSOVAG,PSONAM))
if PSONAM=""
QUIT
SET COUNT2=COUNT2+1
Begin DoDot:1
+3 SET ZZDGDG(SEV,CNT,TYP,PSOVAG,PSONAM)=ZDGDG(SEV,TYP,PSOVAG,PSONAM)
+4 SET ZZDGCK(SEV,CNT,TYP,PSOVAG,PSONAM)=ZDGDG(SEV,TYP,PSOVAG,PSONAM)
End DoDot:1
+5 QUIT
+6 ;
NSRT1 ;sort out dc'd drug therapies local and remote rxs
+1 NEW RXN,SUB
SET (SUB,CT)=0
KILL PSODCTH
+2 FOR
SET CT=$ORDER(^TMP($JOB,LIST,"OUT","THERAPY",CT))
if 'CT
QUIT
FOR
SET SUB=$ORDER(^TMP($JOB,LIST,"OUT","THERAPY",CT,"DRUGS",SUB))
if 'SUB
QUIT
Begin DoDot:1
+3 SET ON=$PIECE(^TMP($JOB,LIST,"OUT","THERAPY",CT,"DRUGS",SUB),"^")
+4 IF $PIECE(ON,";")="O"
IF $PIECE($GET(^PSRX($PIECE(ON,";",2),3)),"^",5)
Begin DoDot:2
+5 SET RXN=$PIECE(ON,";",2)
SET X1=$PIECE($GET(^PSRX($PIECE(ON,";",2),3)),"^",5)
SET X2=(+$PIECE(^PSRX($PIECE(ON,";",2),0),"^",8)+7)
+6 DO C^%DTC
IF X<DT
SET PSODCTH(ON)=1
KILL X,Y,X1,X2
End DoDot:2
QUIT
+7 IF $PIECE(ON,";")="R"
IF $PIECE($GET(^TMP($JOB,LIST,"OUT","REMOTE",$PIECE(ON,";",2))),"^",4)["DISC"
Begin DoDot:2
+8 SET RXN=$PIECE(ON,";",2)
KILL X,Y,X1,X2
+9 SET X=$PIECE(^TMP($JOB,LIST,"OUT","REMOTE",RXN),"^",6)
DO ^%DT
SET X1=Y
SET X2=(+$PIECE(^TMP($JOB,LIST,"OUT","REMOTE",RXN),"^",7)+7)
+10 DO C^%DTC
IF X<DT
SET PSODCTH(ON)=1
KILL X,Y,X1,X2
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
RVAGEN ;va generic for remote drugs
+1 ;*484 - ROUTINE TOO LARGE
DO RVAGEN^PSODDPR4
+2 QUIT
+3 ;
DVAGEN ;va generic for non-va/pending meds
+1 SET PSI=0
NEW PSID,PSODD,PSOVAG
+2 FOR
SET PSI=$ORDER(^PSDRUG("ASP",PSORDIT,PSI))
if 'PSI!($GET(PSID)'="")
QUIT
IF $SELECT('$DATA(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0)
IF $SELECT($PIECE($GET(^PSDRUG(PSI,2)),"^",3)'["X":0,1:1)
SET PSID=$PIECE($GET(^PSDRUG(PSI,0)),"^")
+3 IF PSI=""
SET PSI=0
FOR
SET PSI=$ORDER(^PSDRUG("ASP",PSORDIT,PSI))
if 'PSI!($GET(PSID)'="")
QUIT
IF $SELECT('$DATA(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0)
IF $SELECT($PIECE($GET(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1)
SET PSID=$PIECE($GET(^PSDRUG(PSI,0)),"^")
+4 IF PSI=""
SET PSI=0
FOR
SET PSI=$ORDER(^PSDRUG("ASP",PSORDIT,PSI))
if 'PSI!($GET(PSID)'="")
QUIT
IF $SELECT('$DATA(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0)
IF $SELECT($PIECE($GET(^PSDRUG(PSI,2)),"^",3)'["U":0,1:1)
SET PSID=$PIECE($GET(^PSDRUG(PSI,0)),"^")
+5 IF PSI=""
SET PSI=0
FOR
SET PSI=$ORDER(^PSDRUG("ASP",PSORDIT,PSI))
if 'PSI!($GET(PSID)'="")
QUIT
IF $SELECT('$DATA(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0)
IF $SELECT($PIECE($GET(^PSDRUG(PSI,2)),"^",3)'["I":0,1:1)
SET PSID=$PIECE($GET(^PSDRUG(PSI,0)),"^")
+6 IF PSI=""
SET PSI=0
FOR
SET PSI=$ORDER(^PSDRUG("ASP",PSORDIT,PSI))
if 'PSI!($GET(PSID)'="")
QUIT
IF $SELECT('$DATA(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0)
IF $SELECT('$LENGTH($PIECE($GET(^PSDRUG(PSI,2)),"^",3)):0,1:1)
SET PSID=$PIECE($GET(^PSDRUG(PSI,0)),"^")
+7 IF PSI=""
SET PSI=0
FOR
SET PSI=$ORDER(^PSDRUG("ASP",PSORDIT,PSI))
if 'PSI!($GET(PSID)'="")
QUIT
IF $SELECT('$DATA(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0)
IF $SELECT($LENGTH($PIECE($GET(^PSDRUG(PSI,2)),"^",3)):0,1:1)
SET PSID=$PIECE($GET(^PSDRUG(PSI,0)),"^")
+8 if $GET(PSID)']""
QUIT
+9 SET PSODD=$ORDER(^PSDRUG("B",PSID,0))
DO VAGEN^PSODDPR3(PSODD)
+10 if $GET(PSOVAG)']""
QUIT
+11 SET ZOT=$SELECT($PIECE(ON,";")="O":1,$PIECE(ON,";")="R":2,$PIECE(ON,";")="P":3,1:4)
SET ZDGDG(SV,ZOT,PSOVAG,DRG)=ON_"^"_CT
SET ZZDGDG3(SV,PSOVAG,DRG)=""
SET COUNT=COUNT+1
+12 KILL PSI,PSID,PSORDIT,PSODD,PSOVAG
+13 QUIT
+14 ;
INT ;
+1 IF $GET(PSOVORD)
IF $PIECE(PSOINTV,"^")=1
Begin DoDot:1
+2 KILL DIR,DTOUT,DIRUT,DIROUT,DUOUT
NEW DA
+3 WRITE !
SET DIR(0)="SA^1:YES;0:NO"
SET DIR("A")="Do you want to Continue? "
SET DIR("B")="Y"
DO ^DIR
if ($DATA(DTOUT))!($DATA(DUOUT))!($GET(DIRUT))
SET PSODLQT=1
SET PSORX("DFLG")=1
if $GET(PSODLQT)
QUIT
+4 KILL DIR,DTOUT,DIRUT,DIROUT,DUOUT
+5 IF 'Y
SET PSODLQT=1
SET PSORX("DFLG")=1
QUIT
+6 SET DA=PSONV
SET RXREC=DA
SET RX=$GET(^PSRX(RXREC,0))
SET PSORX("INTERVENE")=1
+7 if '$DATA(PSODGCK)
DO CRI^PSODGDG1
+8 IF $GET(OLDDA)
SET DA=OLDDA
KILL OLDDA
End DoDot:1
QUIT
+9 if $GET(PSODLQT)!($GET(PSORX("DFLG")))
QUIT
+10 IF '$DATA(PSODGCK)
IF $PIECE(PSOINTV,"^")
SET IT=$PIECE(PSOINTV,"^")
SET ON=$PIECE(PSOINTV,"^",2)
DO ^PSODGDGP
KILL DIR
SET IT=$PIECE(PSOINTV,"^")
+11 QUIT
+12 ;
DGCK ;CK - Drug check option at patient profile
+1 IF '$DATA(PSOSD)
DO FULL^VALM1
DO CKMSG
GOTO DGCKQ
+2 NEW PSODGCKX
+3 SET (PSODGCK,PSONCROC)=1
+4 DO FULL^VALM1
+5 DO PSOCK^PSOUTL
+6 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue..."
WRITE !
DO ^DIR
KILL DIR
WRITE @IOF,!
+7 DO SELECT
+8 IF $GET(PSONEW("DFLG"))=1!'$DATA(PSOSD)
WRITE !
GOTO DGCKQ
+9 DO SET^PSODRG
DGCKNP DO POST^PSODRG
DGCKQ SET VALMBCK="R"
+1 KILL PSODGCK,PSODGCKX,MON,PSONEW("DFLG"),PSORX("DFLG"),PSOIENID,PSOGCNPT,PSOGCNID,PSONDFID,DGCKDUPF,PSONCROC
+2 QUIT
+3 ;
GCN(PSOIENID) ;Return 0 for not matched, 1 for matched with no GCNSEQNO, 1^1 for matched with a GCNSEQNO
+1 NEW PSONDFID,PSOGCNPT,PSOGCNID
+2 SET PSONDFID=$PIECE($GET(^PSDRUG(PSOIENID,"ND")),"^")
SET PSOGCNPT=$PIECE($GET(^PSDRUG(PSOIENID,"ND")),"^",3)
+3 IF 'PSONDFID!('PSOGCNPT)
QUIT 0
+4 SET PSOGCNID=$$PROD0^PSNAPIS(PSONDFID,PSOGCNPT)
+5 IF $PIECE(PSOGCNID,"^",7)
QUIT PSOIENID_";"_PSONDFID_";"_$PIECE(PSOGCNID,"^",7)
+6 QUIT PSOIENID_";"_PSONDFID
+7 ;
PKGFLG(PKF1) ;Return 0 for not in range of acceptable package flags, 1 for within range
+1 IF $SELECT(PKF1["O":1,1:0)
QUIT 1
+2 IF $SELECT(PKF1["X":1,1:0)
QUIT 1
+3 QUIT 0
+4 ;
SELECT ;
+1 NEW PSODGCKD
SET PSODGCKD=0
if '$GET(PSORXED)
KILL CLOZPAT
+2 KILL IT,DIC,X,Y,PSODRUG("TRADE NAME"),PSODRUG("NDC"),PSODRUG("DAW"),PSODRUG("BAD")
if $GET(POERR)&($PIECE($GET(OR0),"^",9))
SET Y=$PIECE(^PSDRUG($PIECE(OR0,"^",9),0),"^")
+3 IF $GET(PSODRUG("IEN"))]""
IF '$DATA(PSODGCK)
SET Y=PSODRUG("NAME")
SET PSONEW("OLD VAL")=PSODRUG("IEN")
+4 WRITE !,"DRUG: "
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
IF '$TEST
SET DTOUT=1
+5 IF PSODGCK
IF X=""
IF PSOSD<2
DO CKMSG
SET PSONEW("DFLG")=1
GOTO SELECTX
+6 if X=""
SET PSODGCKX=1
+7 IF X=""
IF $GET(Y)]""
if Y
SET X=Y
if 'X
SET X=$GET(PSODRUG("IEN"))
if X
SET X="`"_X
+8 IF X=""
IF $DATA(PSOSD)
SET X=$ORDER(PSOSD($ORDER(PSOSD("")),""))
SET PSODGCKD=1
+9 IF X=""
IF '$DATA(PSOSD)
Begin DoDot:1
+10 WRITE !!,"Now Processing Enhanced Order Checks! Please wait..."
HANG 1
+11 WRITE !!,"No Order Check Warnings Found",!
KILL DIR
SET DIR("A")="Press Return to continue"
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+12 IF X?1."?"
WRITE !!,"Answer with DRUG NUMBER, or GENERIC NAME, or VA PRODUCT NAME, or",!,"NATIONAL DRUG CLASS, or SYNONYM"
GOTO SELECT
+13 IF $GET(PSORXED)
IF X["^"
SET PSORXED("DFLG")=1
GOTO SELECTX
+14 IF X="^"!(X["^^")!($DATA(DTOUT))
SET PSONEW("DFLG")=1
GOTO SELECTX
+15 IF '$GET(POERR)
IF X[U
IF $LENGTH(X)>1
SET PSODIR("FLD")=PSONEW("FLD")
DO JUMP^PSODIR1
if $GET(PSODIR("FIELD"))
SET PSONEW("FIELD")=PSODIR("FIELD")
KILL PSODIR
SET PSODRG("QFLG")=1
GOTO SELECTX
+16 SET DIC=50
SET DIC(0)="MZV"
SET D="B^C^VAPN^VAC"
+17 IF 'PSODGCKD
SET DIC=50
SET DIC(0)="EMQZVT"
SET DIC("T")=""
SET D="B^C^VAPN^VAC"
+18 IF 'PSODGCKD
SET DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$$GCN^PSODDPR5(+Y),$$PKGFLG^PSODDPR5($P($G(^PSDRUG(+Y,2)),""^"",3)),$D(^PSDRUG(""ASP"",+$G(^(2)),+Y))"
+19 DO MIX^DIC1
KILL DIC,PKF1,D
+20 IF $$PSOSUPCK^PSOUTL(+Y)
GOTO SELECT
+21 SET (DGCKSTA,DGCKDNM)=""
+22 IF '$GET(PSODGCKX)
IF $DATA(PSOSD)
FOR
SET DGCKSTA=$ORDER(PSOSD(DGCKSTA))
if DGCKSTA=""!$GET(DGCKDUPF)
QUIT
FOR
SET DGCKDNM=$ORDER(PSOSD(DGCKSTA,DGCKDNM))
if DGCKDNM=""!$GET(DGCKDUPF)
QUIT
Begin DoDot:1
+23 IF DGCKDNM=$GET(Y(0,0))
Begin DoDot:2
+24 SET DGCKDUPF=1
WRITE !!,"Duplicate Drug in Patient profile, please select a different drug:",!
+25 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue..."
DO ^DIR
KILL DIR
WRITE @IOF
End DoDot:2
End DoDot:1
+26 IF $DATA(DGCKDUPF)
KILL DGCKDUPF,PSODGCKX
GOTO SELECT
+27 IF '$DATA(PSOSD)
Begin DoDot:1
+28 WRITE !!,"Now Processing Enhanced Order Checks! Please wait..."
HANG 1
+29 WRITE !!,"No Order Check Warnings Found",!
KILL DIR
SET DIR("A")="Press Return to continue"
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+30 IF $DATA(DTOUT)
SET PSONEW("DFLG")=1
GOTO SELECTX
+31 IF $DATA(DUOUT)
KILL DUOUT
GOTO SELECT
+32 IF Y<0
GOTO SELECT
+33 if $GET(PSONEW("OLD VAL"))=+Y&('$GET(PSOEDIT))
SET PSODRG("QFLG")=1
+34 KILL PSOY
SET PSOY=Y
SET PSOY(0)=Y(0)
+35 IF $PIECE(PSOY(0),"^")="OTHER DRUG"!($PIECE(PSOY(0),"^")="OUTSIDE DRUG")
DO TRADE^PSODRG
SELECTX KILL X,Y,DTOUT,DUOUT,PSONEW("OLD VAL"),PSODGCKD,DGCKDNM,DGCKSTA
+1 QUIT
+2 ;
CKMSG ;
+1 WRITE !!,"Not enough active profile drugs to perform drug check",!
KILL DIR
SET DIR("A")="Press Return to continue"
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
DO ^DIR
KILL DIR
+2 QUIT
