PSODDPR2 ;BIR/SAB - display enhanced order checks ;11 May 2010 9:06 AM
;;7.0;OUTPATIENT PHARMACY;**251,375,379,390,372,416,411,458,402,634**;DEC 1997;Build 3
;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
;External reference to ^PSDRUG( supported by DBIA 221
;External reference to PSOL^PSSLOCK supported by DBIA 2789
K ^UTILITY($J),PSODRUG("BAD"),THER,THERO,^TMP($J,"PSODCOR"),PSOINTV,PSOVAG,PSODD,PSI,PSORDIT,DRGNM,PDODCNT
I $O(^TMP($J,LIST,"OUT","EXCEPTIONS",""))]"" D EXC^PSODDPR5 G EXIT:$G(PSODLQT)
N COUNT,DRG,ON,CT,DRGI,PDRG,SEV,STX,INT,CLI,PSONULN,PSONULN1,LST,LSI,DGI,SER,SERS,DUPT,SV,PSOLINES,OLDDRG,PSOOLDD,PSOTSUB,PSODSEQ,ZST,ZHDR,ZSUB,ZZDGDGC,PSOCLNS
N PSOSEVER,PSODDSEQ,ZMED,COUNT2
S (ON,DRG,SV,LSI,DGI,SER,SERS,PSOOLDD,PSOSEVER)="",(ZZDGDGC,CT,COUNT)=0,$P(PSONULN,"-",79)="-",$P(PSONULN1,"=",79)="=",ZHDR=1
D NSRT^PSODDPR5 K ^TMP("PSODGI",$J),^TMP("PSOSER",$J),^TMP("PSOSERS",$J),^TMP("PSODGS",$J),^TMP("PSOTDD",$J,1)
S (ON,DRG,SV,DGI,SER,SERS,ZVA)="",(ZST,ZORS,CT,COUNT)=0 N ZZOC S ZZOC=0,PSODDSEQ=0 ; PSO*7*411
F S SV=$O(ZZDGDG(SV)) Q:SV=""!$G(PSODLQT) F S ZST=$O(ZZDGDG(SV,ZST)) Q:'ZST!$G(PSODLQT) F S ZORS=$O(ZZDGDG(SV,ZST,ZORS)) Q:'ZORS!$G(PSODLQT) D
.F S ZVA=$O(ZZDGDG(SV,ZST,ZORS,ZVA)) Q:ZVA=""!$G(PSODLQT) F S DRG=$O(ZZDGDG(SV,ZST,ZORS,ZVA,DRG)) Q:DRG=""!$G(PSODLQT) S COUNT=COUNT+1 D DUP^PSODDPR8,BLD2^PSODGDGP
K HZVA,ZVA,ZORS,ZZDGDG,PSOCLNS,COUNT,ON,DRG,SV,DGI,PSORX("INTERVENE"),DIR,CDDT D HD() G EXIT:$G(PSODLQT) ;PSO*7*411
Q:$D(PSSDIUTL)
I +$G(PSOINTV) D INT G EXIT:$G(PSODLQT)
I $G(PSORX("DFLG")) W:$G(COPY) !,$C(7),"RX DELETED",! S PSORX("DFLG")=1,POERR("DFLG")=1,VALMBCK="R" G EXIT Q
I '$D(^XUSEC("PSORPH",DUZ)) K PSORX("INTERVENE")
;
I $G(PSORX("INTERVENE"))]"" D
.K PSODAL("DA") D FULL^VALM1,^PSORXI S:'$G(POERR) VALMBCK="R" W !
;
I $G(PSORX("DFLG")) G EXIT
I $O(^TMP($J,LIST,"OUT","DRUGDRUG","ERROR",""))]"" D G EXIT:PSODLQT I ($Y+5)>IOSL W @IOF
.S NODDERR=1 K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR
.I ($D(DTOUT))!($D(DUOUT)) S PSODLQT=1,PSORX("DFLG")=1 K DIR,DTOUT,DUOUT Q
.D HD() Q:$G(PSODLQT) W !,"Drug Interaction Error(s):",! S CT=0,ON=""
.F S ON=$O(^TMP($J,LIST,"OUT","DRUGDRUG","ERROR",ON)) Q:ON="" F S CT=$O(^TMP($J,LIST,"OUT","DRUGDRUG","ERROR",ON,CT)) Q:'CT D
..Q:$G(NODDERR)&($P(ON,";")'="Z")
..W ?5,$S($P(ON,";")="N":"",$P(ON,";")="R":"Remote Rx for ",$P(ON,";")="O":"Local Rx for ",1:"Prospective Rx for ")
..W " "_^TMP($J,LIST,"OUT","DRUGDRUG","ERROR",ON,CT,"MSG"),!," "_^TMP($J,LIST,"OUT","DRUGDRUG","ERROR",ON,CT,"TEXT"),!
..D HD() Q:$G(PSODLQT)
;therapy
THER I '$O(^TMP($J,LIST,"OUT","THERAPY",0)) G EXIT
I '$D(^XUSEC("PSORPH",DUZ)),$P(PSOPAR,"^",2),$G(PSOTECCK) G EXIT
D NSRT1^PSODDPR5 K ZPSODCTH ;PSO*7*411
N ON,DDTH,CLASS,QTHER,ZDRG,ZTHER K DUPT,THER,THERO,SUB,ZOT,ZCLASS,CDDT,ZPSODCTH I '$P(PSOPAR,"^",10) D NOCAN^PSODDPR7 G ERR ;PSO*7*411
W @IOF,PSONULN1,! S (SUB,CT,LST,PSOZZ)=0 S (CDDT,THER)=1,THERO=0,QTHER=1 K RXDT ;PSO*7*411
F S CT=$O(^TMP($J,LIST,"OUT","THERAPY",CT)) Q:'CT!$G(PSODLQT) F S SUB=$O(^TMP($J,LIST,"OUT","THERAPY",CT,"DRUGS",SUB)) Q:'SUB!$G(PSODLQT) S ON=$P(^TMP($J,LIST,"OUT","THERAPY",CT,"DRUGS",SUB),"^") D
.I $G(PSODCTH(ON)) Q
.S 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 ZOT=$S($P(ON,";")["C":1,$P(ON,";")="O":2,$P(ON,";")="R":3,$P(ON,";")="P":4,1:5)
.I $P(ON,";")="P" D ;PSO*7*411
..I $G(ZPSODCTH($P(ON,";",2))) Q
..I '$P(^PS(52.41,$P(ON,";",2),0),"^",9) S ZDRG=$P(^PS(50.7,$P(^PS(52.41,$P(ON,";",2),0),"^",8),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")
..E S ZDRG=$P(^PSDRUG($P(^PS(52.41,$P(ON,";",2),0),"^",9),0),"^")
..S ZPSODCTH(ON)=$P(ON,";",2)_";PS(52.41"
.I $P(ON,";")="O" D
..I $G(ZPSODCTH($P(ON,";",2))) Q ;PSO*7*411
..S ZDRG=$P(^PSDRUG($P(^PSRX($P(ON,";",2),0),"^",6),0),"^")
.I $P(ON,";")="N" D
..I $G(ZPSODCTH($P(ON,";",2))) Q ;PSO*7*411
..S DUPRX0=^PS(55,PSODFN,"NVA",$P(ON,";",2),0)
..S ZPSODCTH(ON)="N;"_$P(ON,";",2)
..I '$P(DUPRX0,"^",2) S ZDRG=$P(^PS(50.7,$P(DUPRX0,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^") Q
..S ZDRG=$P(^PSDRUG($P(DUPRX0,"^",2),0),"^")
.I $P(ON,";")="R" D
..Q:'$D(^TMP($J,LIST,"OUT","REMOTE",$P(ON,";",2)))
..I $G(ZPSODCTH($P(ON,";",2))) Q ;PSO*7*411
..S RXREC=^TMP($J,LIST,"OUT","REMOTE",$P(ON,";",2)),ZDRG=$P(RXREC,"^",3)
..S ZPSODCTH(ON)="R;"_$P(RXREC,"^",5)_";"_$P(RXREC,"^")_"^"_$P(RXREC,"^",3)_"^"_$P(RXREC,"^",2)
.I $E($P(ON,";"))["C" D ;PSO*7*411; PIECE 1 of ON can be C1 for IV file 55, C2 for UD file 55, C3 for IV file 53.1 or C4 for UD file 53.1
..S ZPSODCTH(ON)=1,RXREC=^TMP($J,LIST,"IN","PROFILE",ON),ZMED=$P(RXREC,U,3),ZDRG=$P(RXREC,U,4) Q:$D(ZTHER(ZOT_"^"_ZDRG_"^"_ON)) ; clinic order
..S ZPSODCTH(ON)=$S($P(ON,";")[1!$P(ON,";")[4:"V",1:"U")_";"_$P(ON,";",2)
.S:$D(ZDRG) ZTHER(ZOT_"^"_ZDRG_"^"_ON,SUB)=ON K ZDRG
THER2 ;
G EXIT:$G(PSODLQT)
N PSOTHND1,PSOTHND2,PSOTHND3 S PSOTHND2=1,(PSOTHND1,PSOTHND3)=0
I $O(ZTHER(""))]"" D
.S (PSODUPF,PSODUPC,PSODUPC1,PSOTSUB)="" F S PSODUPF=$O(ZTHER(PSODUPF)) Q:PSODUPF="" F S PSOTSUB=$O(ZTHER(PSODUPF,PSOTSUB)) Q:PSOTSUB="" S PSODUPC1=PSODUPC1+1
.;get line counts for each duplicate therapy by setting PSODUPF=1 and calling DUPCL to execute therapy code without actually displaying info. ; no breaks in the middle of displaying individual dup therapies.
.S PSODUPF=1,PSODUPC=0,PSODUPC("CLASS")="" D DUPCL S PSODUPF=0
.;set PSODUPF=0 then call DUPCL to actually print the duplicate therapies.
.D DUPCL K DDTH,PSODUPC,PSODUPF,PSODUPC1,PSODUPC2
G EXIT:$G(PSODLQT)
K PSODCTH,RXDT,PSOZZ
I $P(PSOPAR,"^",10),$O(^TMP($J,"PSODCOR",0)),'$G(PSODGCK) D DCOR^PSODDPR3 K ^TMP($J,"PSODCOR") S PSOTHND1=1 D HD() G EXIT:$G(PSODLQT) ;W !,PSONULN1,!
E D HD() ;I $D(^XUSEC("PSORPH",DUZ)) S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR K DIR W @IOF I '$G(PSODUPF),Y'=1!($D(DTOUT))!($D(DUOUT)) S PSODLQT=1,PSORX("DFLG")=1 Q
I 'PSOTHND1,'$G(PSODLQT),$D(^XUSEC("PSORPH",DUZ)) S PSOTHND3=1 D RTC
I PSOTHND3>1,'$G(PSODLQT),$D(^XUSEC("PSORPH",DUZ)) D RTC
ERR I $O(^TMP($J,LIST,"OUT","THERAPY","ERROR",""))]"" D S NODTERR=1 K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR
.D HD() Q:$G(PSODLQT) W !,"Drug Therapy Error(s):",! S CT=0,ON=""
.F S ON=$O(^TMP($J,LIST,"OUT","THERAPY","ERROR",ON)) Q:ON=""!$G(PSODLQT) F S CT=$O(^TMP($J,LIST,"OUT","THERAPY","ERROR",ON,CT)) Q:'CT!$G(PSODLQT) D
..Q:$G(NODTERR)&($P(ON,";")'="Z")!$G(PSODLQT)
..D HD() Q:$G(PSODLQT) W ?5,$S($P(ON,";")="P":"Pending Order: ",$P(ON,";")="N":"Non-VA Med Order: ",$P(ON,";")="R":"Remote Rx: ",$P(ON,";")="O":"Rx: ",1:"Prospective Rx: ")
..D HD() Q:$G(PSODLQT) W " "_^TMP($J,LIST,"OUT","THERAPY","ERROR",ON,CT,"MSG"),!," "_^TMP($J,LIST,"OUT","THERAPY","ERROR",ON,CT,"TEXT"),!
K ZON,ZPSOCTH,ZDDT
I $O(^TMP($J,LIST,"OUT","THERAPY","ERROR",""))]"" S:($D(DTOUT))!($D(DUOUT))!($G(DIRUT)) PSODLQT=1,PSORX("DFLG")=1 K DIR,DTOUT,DUOUT Q:$G(PSODLQT)
D HD()
EXIT ;
D ^PSOBUILD
K DSPL,CAN,DA,DIR,DNM,DUPRX0,ISSD,J,LSTFL,MSG,PHYS,PSOCLC,PSONULN,REA,RFLS,RX0,RX2,RXN,RXREC,ST,Y,ZZ,ACT,PSOCLOZ,PSOLR,PSOLDT,PSOCD,SIG,ZCT,ZZCT,ZZZCT,CDDT ;PSO*7*411
K IT,LST,THER,THERO,^UTILITY($J),DGI,SER,SEV,SERS,BSIG,I,NODDERR,NODTERR,PDRG,DRGI,STATUS,^UTILITY($J,"W"),X,ZX,DIWL,DIWR,DIWF,THER,THERO,PSOINTV,ZTHER,PSOVORD,PSODCTH,ZZDGDG,ZZDGDG2,ZZHDR
Q
;
RX D HD() Q:$G(PSODLQT) W ! S RXREC=$P(ON,";",2)
S DUPRX0=^PSRX(RXREC,0),RFLS=$P(DUPRX0,"^",9),ISSD=$P(^PSRX(RXREC,0),"^",13),RX0=DUPRX0,RX2=^PSRX(RXREC,2),STATUS=+$G(^PSRX(RXREC,"STA"))
S RXRECLOC=$G(RXREC)
S J=RXREC D STAT^PSOFUNC K RX0,RX2
I $P($G(^PS(53,+$P($G(PSORX("PATIENT STATUS")),"^"),0)),"^")["AUTH ABS"!($G(PSORX("PATIENT STATUS"))["AUTH ABS")&'$P(PSOPAR,"^",5) W !,"PATIENT ON AUTHORIZED ABSENCE!" K RXRECLOC Q
I STATUS>10,STATUS'=16 K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR W @IOF S:($D(DTOUT))!($D(DUOUT))!($G(DIRUT)) PSODLQT=1,PSORX("DFLG")=1 K DIR,DTOUT,DUOUT,DIRUT,RXRECLOC Q
I '$P(PSOPAR,"^",2),'$P(PSOPAR,"^",16),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("DFLG")=1 K RXRECLOC Q
I $P(PSOPAR,"^",2),'$P(PSOPAR,"^",16),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("DFLG")=1 K RXRECLOC Q
I STATUS=16 W !!,"Prescription "_$P($G(^PSRX(+$G(RXRECLOC),0)),"^")_" is on Provider Hold, it cannot be discontinued.",! K DUP,RXRECLOC S PSORX("DFLG")=1 Q
D PSOL^PSSLOCK(RXRECLOC) I '$G(PSOMSG) D K PSOMSG,DIR,DUP,RXRECLOC S DIR("A")="Press Return to continue",DIR(0)="E",DIR("?")="Press Return to continue" D ^DIR K DIR S PSORX("DFLG")=1 Q
.I $P($G(PSOMSG),"^",2)'="" W !!,$P(PSOMSG,"^",2),! Q
.W !!,"Another person is editing Rx #"_$P($G(^PSRX(RXREC,0)),"^"),!
K PSOMSG S DIR("A")=$S(STATUS=12:"Reinstate",1:"Discontinue")_" RX # "_$P(^PSRX(RXREC,0),"^"),DIR(0)="Y",DIR("?")="Enter Y to "_$S(STATUS=12:"reinstate",1:"discontinue")_" this RX."
D ^DIR K DIR S:($D(DTOUT))!($D(DUOUT))!($G(DIRUT)) PSODLQT=1,PSORX("DFLG")=1 Q:$G(PSODLQT)
S DA=RXREC S ACT=$S($D(SPCANC):"Reinstated during Rx cancel.",1:$S(STATUS=12:"Reinstated",1:"Discontinued")_" while "_$S('$G(PSONV):"entering",1:"verifying")_" new RX")
D CMOP^PSOUTL I $G(CMOP("S"))="L" W !,"A CMOP Rx cannot be discontinued during transmission!",! S Y=0 K CMOP
I 'Y W $C(7)," -Prescription was not "_$S(STATUS=12:"reinstated",1:"discontinued")_"..." D Q
.S:'$D(PSOCLC) PSOCLC=DUZ S MSG=ACT,REA=$S(STATUS=12:"R",1:"C") S:$G(DUP) PSORX("DFLG")=1 K DUP
.I $D(^TMP("PSORXDC",$J,RXREC,0)) K ^TMP("PSORXDC",$J,RXREC,0)
S PSOCLC=DUZ,MSG=$S($G(MSG)]"":MSG,1:ACT_" During New RX "_$S('$G(PSONV):"Entry",1:"Verification")_" - Duplicate Rx"),REA=$S(STATUS=12:"R",1:"C")
W !!,"THERAPEUTIC DUPLICATIONS will be discontinued after the acceptance of the new order.",!!
S ^TMP("PSORXDC",$J,RXREC,0)="52^"_DA_"^"_MSG_"^"_REA_"^"_ACT_"^"_ST_"^"_DRG,PSONOOR="D"
K RXRECLOC,DUP,CLS,PSONOOR,STATUS,ACT,PSONV,REA,SPCANC
Q
;
DUPCL ;
Q:$G(PSODLQT)
S:$G(PSODUPF) PSODUPC=PSODUPC+1 ;W:'$G(PSODUPF) @IOF,PSONULN1,!
I '$G(PSODUPF) W "*** THERAPEUTIC DUPLICATION(S) *** "_PSODRUG("NAME")_" with"
S:$G(PSODUPF) PSODUPC=PSODUPC+1 N PSODUPCT,PSODUPC2,PSODUPCL
S (PSODUPC2,PSODUPCT)=0 S:'$G(PSODUPF) PSODUPCT=2
;displays order and therapy
K DDTH S (PSODUPCL,ZSUB,ZCT,PSODSEQ)=""
F S ZCT=$O(ZTHER(ZCT)) Q:ZCT=""!($G(PSODLQT)) F S PSODSEQ=$O(ZTHER(ZCT,PSODSEQ)) Q:PSODSEQ=""!($G(PSODLQT)) S ON=ZTHER(ZCT,PSODSEQ) D
.I '$G(PSODUPF) S PSOTHND3=PSOTHND3+1 I 'PSOTHND1,'$G(PSODLQT),$O(ZTHER(ZCT,PSODSEQ)),PSOTHND3>1 D RTC
.S (PDODCNT,PSOTHND1)=0,PSODUPC2=PSODUPC2+1 I $G(PSODUPF) S PSODUPC(ZCT)=0
.I PSODUPC2=PSODUPC2+1
.I '$G(PSODUPF) D
..I PSODUPC2=PSODUPC1,(PSODUPCT+PSODUPC(ZCT)+PSODUPC("CLASS"))>22 D HD(15) Q:$G(PSODLQT) S PSODUPCT=0
..I (PSODUPCT+PSODUPC(ZCT))>22 D HD(15) Q:$G(PSODLQT) S PSODUPCT=0
..S PSODUPCT=PSODUPCT+PSODUPC(ZCT)
.I $P(ON,";")="O" D HD() Q:$G(PSODLQT) S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) ! S THER=1 D DDRX^PSODDPR8 D
..Q:STATUS>5&(STATUS'=16)
..Q:$G(^TMP("PSORXDC",$J,RXREC,0))]""
..Q:$G(RXDT("O",RXREC))
..S RX0=^PSRX(RXREC,0),J=RXREC,RX2=^PSRX(RXREC,2) D STAT^PSOFUNC K RX0,RX2
..S PSOZZ=PSOZZ+1,^TMP($J,"PSODCOR",PSOZZ)="52"_"^"_RXREC_"^"_ST_"^"_DRGNM,RXDT("O",RXREC)=1
.I $P(ON,";")="N" D HD() Q:$G(PSODLQT) S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) ! D ^PSODDPR3
.I $P(ON,";")="P" D
..; PSO*7*411
..D HD(8) Q:$G(PSODLQT) S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) ! S RXREC=$P(ON,";",2),THER=1 D PEND^PSODDPR8
..Q:$G(^TMP("PSORXDC",$J,RXREC,0))]""
..Q:$G(RXDT("P",RXREC))
..S PSOZZ=PSOZZ+1,DUPRX0=^PS(52.41,RXREC,0)
..S ^TMP($J,"PSODCOR",PSOZZ)="P"_"^"_RXREC_"^^"_$S($P(DUPRX0,"^",9):$P(^PSDRUG($P(DUPRX0,"^",9),0),"^"),1:$P(^PS(50.7,$P(DUPRX0,"^",8),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(DUPRX0,"^",8),0),"^",2),0),"^"))
..S ^TMP($J,"PSODCOR",PSOZZ)=^TMP($J,"PSODCOR",PSOZZ)_"^"_$S('$P(DUPRX0,"^",9):$P(^PS(50.7,$P(DUPRX0,"^",8),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(DUPRX0,"^",8),0),"^",2),0),"^"),1:$P(^PSDRUG($P(DUPRX0,"^",9),0),"^"))
..S RXDT("P",RXREC)=1
.I $P(ON,";")="R" S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) ! D RDI^PSODDPR3 D HD() Q:$G(PSODLQT)
.I $E($P(ON,";"))="C" D HD() Q:$G(PSODLQT) S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) ! D DUP^PSODDPR7 ; clinic order
.I $O(ZTHER(ZCT,PSODSEQ))'="" D HD() Q:$G(PSODLQT) S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) !,PSONULN
D CLASSES^PSODDPR3
;format therapy classes pso*7*411
N X S (ZCT,ZZCT,ZZZCT)=0
F S ZZCT=$O(^TMP($J,LIST,"OUT","THERAPY",ZZCT)) Q:'ZZCT S ZCT=0 F S ZCT=$O(^TMP($J,LIST,"OUT","THERAPY",ZZCT,ZCT)) Q:'ZCT D
.;S X=^TMP($J,LIST,"OUT","THERAPY",ZZCT,ZCT,"CLASS") ; ME2 - 1602256
.S X=^TMP($J,LIST,"OUT","THERAPY",ZZCT,ZCT,"CLASS")_$S($O(^TMP($J,LIST,"OUT","THERAPY",ZZCT))!($O(^TMP($J,LIST,"OUT","THERAPY",ZZCT,ZCT))):", ",1:"")
Q:$G(PSODLQT)!($D(^XUSEC("PSORPH",DUZ)))
I '$G(PSODUPF),'$D(^XUSEC("PSORPH",DUZ)) D
.S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR K DIR W @IOF
.I '$G(PSODUPF),Y'=1!($D(DTOUT))!($D(DUOUT)) S PSODLQT=1,PSORX("DFLG")=1 Q
.I '$G(PSODUPF),($Y+5)>IOSL W @IOF
Q
INT ;
Q:$D(PSSDIUTL)
D INT^PSODDPR5
Q
HD(PSOLINES,OVRRID) ;
Q:$G(PSODUPF) ;P634
S:'$G(PSODLQT) PSODLQT=0 S:'$G(OVRRID) OVRRID=0 S:'$G(PSOLINES) PSOLINES=5
I '$G(OVRRID),$G(PSODLQT)!(($Y+PSOLINES)'>IOSL) Q
I $G(PSOTHND2) S PSOTHND1=1
N DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
W ! K DIR,Y S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR
K PSOLINES,OVRRID
I Y'=1!($D(DTOUT))!($D(DUOUT)) S PSODLQT=1,PSORX("DFLG")=1 Q
W:'$G(PSODUPF) @IOF
Q
;
DGSORT ;
;this sort is used in monograph and clinic effects display so that they are displayed once per VA generic drug
S (SEV,TYP,PSOVAG,PSONAM)="" F S SEV=$O(ZZDGDG3(SEV)) Q:SEV="" F S PSOVAG=$O(ZZDGDG3(SEV,PSOVAG)) Q:PSOVAG="" D
.S COUNT2=0 F S PSONAM=$O(ZZDGDG3(SEV,PSOVAG,PSONAM)) Q:PSONAM="" S COUNT2=COUNT2+1,ZZDGDG2(SEV,PSOVAG)=COUNT2
K COUNT2,PSONAM
Q
;
;
RTC ;Return to continue
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT S DIR(0)="EA",DIR("A")="Press Return to Continue: " D ^DIR K DIR W @IOF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODDPR2 14688 printed Sep 23, 2025@20:02:40 Page 2
PSODDPR2 ;BIR/SAB - display enhanced order checks ;11 May 2010 9:06 AM
+1 ;;7.0;OUTPATIENT PHARMACY;**251,375,379,390,372,416,411,458,402,634**;DEC 1997;Build 3
+2 ;External reference to ^PS(50.606 supported by DBIA 2174
+3 ;External reference to ^PS(50.7 supported by DBIA 2223
+4 ;External reference to ^PS(55 supported by DBIA 2228
+5 ;External reference to ^PSDRUG( supported by DBIA 221
+6 ;External reference to PSOL^PSSLOCK supported by DBIA 2789
+7 KILL ^UTILITY($JOB),PSODRUG("BAD"),THER,THERO,^TMP($JOB,"PSODCOR"),PSOINTV,PSOVAG,PSODD,PSI,PSORDIT,DRGNM,PDODCNT
+8 IF $ORDER(^TMP($JOB,LIST,"OUT","EXCEPTIONS",""))]""
DO EXC^PSODDPR5
if $GET(PSODLQT)
GOTO EXIT
+9 NEW COUNT,DRG,ON,CT,DRGI,PDRG,SEV,STX,INT,CLI,PSONULN,PSONULN1,LST,LSI,DGI,SER,SERS,DUPT,SV,PSOLINES,OLDDRG,PSOOLDD,PSOTSUB,PSODSEQ,ZST,ZHDR,ZSUB,ZZDGDGC,PSOCLNS
+10 NEW PSOSEVER,PSODDSEQ,ZMED,COUNT2
+11 SET (ON,DRG,SV,LSI,DGI,SER,SERS,PSOOLDD,PSOSEVER)=""
SET (ZZDGDGC,CT,COUNT)=0
SET $PIECE(PSONULN,"-",79)="-"
SET $PIECE(PSONULN1,"=",79)="="
SET ZHDR=1
+12 DO NSRT^PSODDPR5
KILL ^TMP("PSODGI",$JOB),^TMP("PSOSER",$JOB),^TMP("PSOSERS",$JOB),^TMP("PSODGS",$JOB),^TMP("PSOTDD",$JOB,1)
+13 ; PSO*7*411
SET (ON,DRG,SV,DGI,SER,SERS,ZVA)=""
SET (ZST,ZORS,CT,COUNT)=0
NEW ZZOC
SET ZZOC=0
SET PSODDSEQ=0
+14 FOR
SET SV=$ORDER(ZZDGDG(SV))
if SV=""!$GET(PSODLQT)
QUIT
FOR
SET ZST=$ORDER(ZZDGDG(SV,ZST))
if 'ZST!$GET(PSODLQT)
QUIT
FOR
SET ZORS=$ORDER(ZZDGDG(SV,ZST,ZORS))
if 'ZORS!$GET(PSODLQT)
QUIT
Begin DoDot:1
+15 FOR
SET ZVA=$ORDER(ZZDGDG(SV,ZST,ZORS,ZVA))
if ZVA=""!$GET(PSODLQT)
QUIT
FOR
SET DRG=$ORDER(ZZDGDG(SV,ZST,ZORS,ZVA,DRG))
if DRG=""!$GET(PSODLQT)
QUIT
SET COUNT=COUNT+1
DO DUP^PSODDPR8
DO BLD2^PSODGDGP
End DoDot:1
+16 ;PSO*7*411
KILL HZVA,ZVA,ZORS,ZZDGDG,PSOCLNS,COUNT,ON,DRG,SV,DGI,PSORX("INTERVENE"),DIR,CDDT
DO HD()
if $GET(PSODLQT)
GOTO EXIT
+17 if $DATA(PSSDIUTL)
QUIT
+18 IF +$GET(PSOINTV)
DO INT
if $GET(PSODLQT)
GOTO EXIT
+19 IF $GET(PSORX("DFLG"))
if $GET(COPY)
WRITE !,$CHAR(7),"RX DELETED",!
SET PSORX("DFLG")=1
SET POERR("DFLG")=1
SET VALMBCK="R"
GOTO EXIT
QUIT
+20 IF '$DATA(^XUSEC("PSORPH",DUZ))
KILL PSORX("INTERVENE")
+21 ;
+22 IF $GET(PSORX("INTERVENE"))]""
Begin DoDot:1
+23 KILL PSODAL("DA")
DO FULL^VALM1
DO ^PSORXI
if '$GET(POERR)
SET VALMBCK="R"
WRITE !
End DoDot:1
+24 ;
+25 IF $GET(PSORX("DFLG"))
GOTO EXIT
+26 IF $ORDER(^TMP($JOB,LIST,"OUT","DRUGDRUG","ERROR",""))]""
Begin DoDot:1
+27 SET NODDERR=1
KILL DIR
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
SET DIR("A")="Press Return to Continue"
DO ^DIR
+28 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET PSODLQT=1
SET PSORX("DFLG")=1
KILL DIR,DTOUT,DUOUT
QUIT
+29 DO HD()
if $GET(PSODLQT)
QUIT
WRITE !,"Drug Interaction Error(s):",!
SET CT=0
SET ON=""
+30 FOR
SET ON=$ORDER(^TMP($JOB,LIST,"OUT","DRUGDRUG","ERROR",ON))
if ON=""
QUIT
FOR
SET CT=$ORDER(^TMP($JOB,LIST,"OUT","DRUGDRUG","ERROR",ON,CT))
if 'CT
QUIT
Begin DoDot:2
+31 if $GET(NODDERR)&($PIECE(ON,";")'="Z")
QUIT
+32 WRITE ?5,$SELECT($PIECE(ON,";")="N":"",$PIECE(ON,";")="R":"Remote Rx for ",$PIECE(ON,";")="O":"Local Rx for ",1:"Prospective Rx for ")
+33 WRITE " "_^TMP($JOB,LIST,"OUT","DRUGDRUG","ERROR",ON,CT,"MSG"),!," "_^TMP($JOB,LIST,"OUT","DRUGDRUG","ERROR",ON,CT,"TEXT"),!
+34 DO HD()
if $GET(PSODLQT)
QUIT
End DoDot:2
End DoDot:1
if PSODLQT
GOTO EXIT
IF ($Y+5)>IOSL
WRITE @IOF
+35 ;therapy
THER IF '$ORDER(^TMP($JOB,LIST,"OUT","THERAPY",0))
GOTO EXIT
+1 IF '$DATA(^XUSEC("PSORPH",DUZ))
IF $PIECE(PSOPAR,"^",2)
IF $GET(PSOTECCK)
GOTO EXIT
+2 ;PSO*7*411
DO NSRT1^PSODDPR5
KILL ZPSODCTH
+3 ;PSO*7*411
NEW ON,DDTH,CLASS,QTHER,ZDRG,ZTHER
KILL DUPT,THER,THERO,SUB,ZOT,ZCLASS,CDDT,ZPSODCTH
IF '$PIECE(PSOPAR,"^",10)
DO NOCAN^PSODDPR7
GOTO ERR
+4 ;PSO*7*411
WRITE @IOF,PSONULN1,!
SET (SUB,CT,LST,PSOZZ)=0
SET (CDDT,THER)=1
SET THERO=0
SET QTHER=1
KILL RXDT
+5 FOR
SET CT=$ORDER(^TMP($JOB,LIST,"OUT","THERAPY",CT))
if 'CT!$GET(PSODLQT)
QUIT
FOR
SET SUB=$ORDER(^TMP($JOB,LIST,"OUT","THERAPY",CT,"DRUGS",SUB))
if 'SUB!$GET(PSODLQT)
QUIT
SET ON=$PIECE(^TMP($JOB,LIST,"OUT","THERAPY",CT,"DRUGS",SUB),"^")
Begin DoDot:1
+6 IF $GET(PSODCTH(ON))
QUIT
+7 SET RXREC=$PIECE(ON,";",2)
+8 IF $PIECE(ON,";")="Z"
QUIT
+9 IF $PIECE(ON,";")="N"
IF $GET(^TMP($JOB,"PSONVADD",RXREC,0))
QUIT
+10 IF $PIECE(ON,";")="R"
IF $GET(^TMP($JOB,"PSORMDD",RXREC,0))
QUIT
+11 IF $PIECE(ON,";")="O"
IF $GET(^TMP("PSORXDC",$JOB,RXREC,0))
QUIT
+12 IF $PIECE(ON,";")="P"
IF $GET(^TMP("PSORXDC",$JOB,RXREC,0))
QUIT
+13 IF $PIECE(ON,";")="O"
IF $GET(^TMP("PSORXDD",$JOB,RXREC,0))
QUIT
+14 SET ZOT=$SELECT($PIECE(ON,";")["C":1,$PIECE(ON,";")="O":2,$PIECE(ON,";")="R":3,$PIECE(ON,";")="P":4,1:5)
+15 ;PSO*7*411
IF $PIECE(ON,";")="P"
Begin DoDot:2
+16 IF $GET(ZPSODCTH($PIECE(ON,";",2)))
QUIT
+17 IF '$PIECE(^PS(52.41,$PIECE(ON,";",2),0),"^",9)
SET ZDRG=$PIECE(^PS(50.7,$PIECE(^PS(52.41,$PIECE(ON,";",2),0),"^",8),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^")
+18 IF '$TEST
SET ZDRG=$PIECE(^PSDRUG($PIECE(^PS(52.41,$PIECE(ON,";",2),0),"^",9),0),"^")
+19 SET ZPSODCTH(ON)=$PIECE(ON,";",2)_";PS(52.41"
End DoDot:2
+20 IF $PIECE(ON,";")="O"
Begin DoDot:2
+21 ;PSO*7*411
IF $GET(ZPSODCTH($PIECE(ON,";",2)))
QUIT
+22 SET ZDRG=$PIECE(^PSDRUG($PIECE(^PSRX($PIECE(ON,";",2),0),"^",6),0),"^")
End DoDot:2
+23 IF $PIECE(ON,";")="N"
Begin DoDot:2
+24 ;PSO*7*411
IF $GET(ZPSODCTH($PIECE(ON,";",2)))
QUIT
+25 SET DUPRX0=^PS(55,PSODFN,"NVA",$PIECE(ON,";",2),0)
+26 SET ZPSODCTH(ON)="N;"_$PIECE(ON,";",2)
+27 IF '$PIECE(DUPRX0,"^",2)
SET ZDRG=$PIECE(^PS(50.7,$PIECE(DUPRX0,"^"),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^")
QUIT
+28 SET ZDRG=$PIECE(^PSDRUG($PIECE(DUPRX0,"^",2),0),"^")
End DoDot:2
+29 IF $PIECE(ON,";")="R"
Begin DoDot:2
+30 if '$DATA(^TMP($JOB,LIST,"OUT","REMOTE",$PIECE(ON,";",2)))
QUIT
+31 ;PSO*7*411
IF $GET(ZPSODCTH($PIECE(ON,";",2)))
QUIT
+32 SET RXREC=^TMP($JOB,LIST,"OUT","REMOTE",$PIECE(ON,";",2))
SET ZDRG=$PIECE(RXREC,"^",3)
+33 SET ZPSODCTH(ON)="R;"_$PIECE(RXREC,"^",5)_";"_$PIECE(RXREC,"^")_"^"_$PIECE(RXREC,"^",3)_"^"_$PIECE(RXREC,"^",2)
End DoDot:2
+34 ;PSO*7*411; PIECE 1 of ON can be C1 for IV file 55, C2 for UD file 55, C3 for IV file 53.1 or C4 for UD file 53.1
IF $EXTRACT($PIECE(ON,";"))["C"
Begin DoDot:2
+35 ; clinic order
SET ZPSODCTH(ON)=1
SET RXREC=^TMP($JOB,LIST,"IN","PROFILE",ON)
SET ZMED=$PIECE(RXREC,U,3)
SET ZDRG=$PIECE(RXREC,U,4)
if $DATA(ZTHER(ZOT_"^"_ZDRG_"^"_ON))
QUIT
+36 SET ZPSODCTH(ON)=$SELECT($PIECE(ON,";")[1!$PIECE(ON,";")[4:"V",1:"U")_";"_$PIECE(ON,";",2)
End DoDot:2
+37 if $DATA(ZDRG)
SET ZTHER(ZOT_"^"_ZDRG_"^"_ON,SUB)=ON
KILL ZDRG
End DoDot:1
THER2 ;
+1 if $GET(PSODLQT)
GOTO EXIT
+2 NEW PSOTHND1,PSOTHND2,PSOTHND3
SET PSOTHND2=1
SET (PSOTHND1,PSOTHND3)=0
+3 IF $ORDER(ZTHER(""))]""
Begin DoDot:1
+4 SET (PSODUPF,PSODUPC,PSODUPC1,PSOTSUB)=""
FOR
SET PSODUPF=$ORDER(ZTHER(PSODUPF))
if PSODUPF=""
QUIT
FOR
SET PSOTSUB=$ORDER(ZTHER(PSODUPF,PSOTSUB))
if PSOTSUB=""
QUIT
SET PSODUPC1=PSODUPC1+1
+5 ;get line counts for each duplicate therapy by setting PSODUPF=1 and calling DUPCL to execute therapy code without actually displaying info. ; no breaks in the middle of displaying individual dup therapies.
+6 SET PSODUPF=1
SET PSODUPC=0
SET PSODUPC("CLASS")=""
DO DUPCL
SET PSODUPF=0
+7 ;set PSODUPF=0 then call DUPCL to actually print the duplicate therapies.
+8 DO DUPCL
KILL DDTH,PSODUPC,PSODUPF,PSODUPC1,PSODUPC2
End DoDot:1
+9 if $GET(PSODLQT)
GOTO EXIT
+10 KILL PSODCTH,RXDT,PSOZZ
+11 ;W !,PSONULN1,!
IF $PIECE(PSOPAR,"^",10)
IF $ORDER(^TMP($JOB,"PSODCOR",0))
IF '$GET(PSODGCK)
DO DCOR^PSODDPR3
KILL ^TMP($JOB,"PSODCOR")
SET PSOTHND1=1
DO HD()
if $GET(PSODLQT)
GOTO EXIT
+12 ;I $D(^XUSEC("PSORPH",DUZ)) S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR K DIR W @IOF I '$G(PSODUPF),Y'=1!($D(DTOUT))!($D(DUOUT)) S PSODLQT=1,PSORX("DFLG")=1 Q
IF '$TEST
DO HD()
+13 IF 'PSOTHND1
IF '$GET(PSODLQT)
IF $DATA(^XUSEC("PSORPH",DUZ))
SET PSOTHND3=1
DO RTC
+14 IF PSOTHND3>1
IF '$GET(PSODLQT)
IF $DATA(^XUSEC("PSORPH",DUZ))
DO RTC
ERR IF $ORDER(^TMP($JOB,LIST,"OUT","THERAPY","ERROR",""))]""
Begin DoDot:1
+1 DO HD()
if $GET(PSODLQT)
QUIT
WRITE !,"Drug Therapy Error(s):",!
SET CT=0
SET ON=""
+2 FOR
SET ON=$ORDER(^TMP($JOB,LIST,"OUT","THERAPY","ERROR",ON))
if ON=""!$GET(PSODLQT)
QUIT
FOR
SET CT=$ORDER(^TMP($JOB,LIST,"OUT","THERAPY","ERROR",ON,CT))
if 'CT!$GET(PSODLQT)
QUIT
Begin DoDot:2
+3 if $GET(NODTERR)&($PIECE(ON,";")'="Z")!$GET(PSODLQT)
QUIT
+4 DO HD()
if $GET(PSODLQT)
QUIT
WRITE ?5,$SELECT($PIECE(ON,";")="P":"Pending Order: ",$PIECE(ON,";")="N":"Non-VA Med Order: ",$PIECE(ON,";")="R":"Remote Rx: ",$PIECE(ON,";")="O":"Rx: ",1:"Prospective Rx: ")
+5 DO HD()
if $GET(PSODLQT)
QUIT
WRITE " "_^TMP($JOB,LIST,"OUT","THERAPY","ERROR",ON,CT,"MSG"),!," "_^TMP($JOB,LIST,"OUT","THERAPY","ERROR",ON,CT,"TEXT"),!
End DoDot:2
End DoDot:1
SET NODTERR=1
KILL DIR
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
SET DIR("A")="Press Return to Continue"
DO ^DIR
+6 KILL ZON,ZPSOCTH,ZDDT
+7 IF $ORDER(^TMP($JOB,LIST,"OUT","THERAPY","ERROR",""))]""
if ($DATA(DTOUT))!($DATA(DUOUT))!($GET(DIRUT))
SET PSODLQT=1
SET PSORX("DFLG")=1
KILL DIR,DTOUT,DUOUT
if $GET(PSODLQT)
QUIT
+8 DO HD()
EXIT ;
+1 DO ^PSOBUILD
+2 ;PSO*7*411
KILL DSPL,CAN,DA,DIR,DNM,DUPRX0,ISSD,J,LSTFL,MSG,PHYS,PSOCLC,PSONULN,REA,RFLS,RX0,RX2,RXN,RXREC,ST,Y,ZZ,ACT,PSOCLOZ,PSOLR,PSOLDT,PSOCD,SIG,ZCT,ZZCT,ZZZCT,CDDT
+3 KILL IT,LST,THER,THERO,^UTILITY($JOB),DGI,SER,SEV,SERS,BSIG,I,NODDERR,NODTERR,PDRG,DRGI,STATUS,^UTILITY($JOB,"W"),X,ZX,DIWL,DIWR,DIWF,THER,THERO,PSOINTV,ZTHER,PSOVORD,PSODCTH,ZZDGDG,ZZDGDG2,ZZHDR
+4 QUIT
+5 ;
RX DO HD()
if $GET(PSODLQT)
QUIT
WRITE !
SET RXREC=$PIECE(ON,";",2)
+1 SET DUPRX0=^PSRX(RXREC,0)
SET RFLS=$PIECE(DUPRX0,"^",9)
SET ISSD=$PIECE(^PSRX(RXREC,0),"^",13)
SET RX0=DUPRX0
SET RX2=^PSRX(RXREC,2)
SET STATUS=+$GET(^PSRX(RXREC,"STA"))
+2 SET RXRECLOC=$GET(RXREC)
+3 SET J=RXREC
DO STAT^PSOFUNC
KILL RX0,RX2
+4 IF $PIECE($GET(^PS(53,+$PIECE($GET(PSORX("PATIENT STATUS")),"^"),0)),"^")["AUTH ABS"!($GET(PSORX("PATIENT STATUS"))["AUTH ABS")&'$PIECE(PSOPAR,"^",5)
WRITE !,"PATIENT ON AUTHORIZED ABSENCE!"
KILL RXRECLOC
QUIT
+5 IF STATUS>10
IF STATUS'=16
KILL DIR
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
SET DIR("A")="Press Return to continue"
DO ^DIR
WRITE @IOF
if ($DATA(DTOUT))!($DATA(DUOUT))!($GET(DIRUT))
SET PSODLQT=1
SET PSORX("DFLG")=1
KILL DIR,DTOUT,DUOUT,DIRUT,RXRECLOC
QUIT
+6 IF '$PIECE(PSOPAR,"^",2)
IF '$PIECE(PSOPAR,"^",16)
IF '$DATA(^XUSEC("PSORPH",DUZ))
SET PSORX("DFLG")=1
KILL RXRECLOC
QUIT
+7 IF $PIECE(PSOPAR,"^",2)
IF '$PIECE(PSOPAR,"^",16)
IF '$DATA(^XUSEC("PSORPH",DUZ))
SET PSORX("DFLG")=1
KILL RXRECLOC
QUIT
+8 IF STATUS=16
WRITE !!,"Prescription "_$PIECE($GET(^PSRX(+$GET(RXRECLOC),0)),"^")_" is on Provider Hold, it cannot be discontinued.",!
KILL DUP,RXRECLOC
SET PSORX("DFLG")=1
QUIT
+9 DO PSOL^PSSLOCK(RXRECLOC)
IF '$GET(PSOMSG)
Begin DoDot:1
+10 IF $PIECE($GET(PSOMSG),"^",2)'=""
WRITE !!,$PIECE(PSOMSG,"^",2),!
QUIT
+11 WRITE !!,"Another person is editing Rx #"_$PIECE($GET(^PSRX(RXREC,0)),"^"),!
End DoDot:1
KILL PSOMSG,DIR,DUP,RXRECLOC
SET DIR("A")="Press Return to continue"
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
DO ^DIR
KILL DIR
SET PSORX("DFLG")=1
QUIT
+12 KILL PSOMSG
SET DIR("A")=$SELECT(STATUS=12:"Reinstate",1:"Discontinue")_" RX # "_$PIECE(^PSRX(RXREC,0),"^")
SET DIR(0)="Y"
SET DIR("?")="Enter Y to "_$SELECT(STATUS=12:"reinstate",1:"discontinue")_" this RX."
+13 DO ^DIR
KILL DIR
if ($DATA(DTOUT))!($DATA(DUOUT))!($GET(DIRUT))
SET PSODLQT=1
SET PSORX("DFLG")=1
if $GET(PSODLQT)
QUIT
+14 SET DA=RXREC
SET ACT=$SELECT($DATA(SPCANC):"Reinstated during Rx cancel.",1:$SELECT(STATUS=12:"Reinstated",1:"Discontinued")_" while "_$SELECT('$GET(PSONV):"entering",1:"verifying")_" new RX")
+15 DO CMOP^PSOUTL
IF $GET(CMOP("S"))="L"
WRITE !,"A CMOP Rx cannot be discontinued during transmission!",!
SET Y=0
KILL CMOP
+16 IF 'Y
WRITE $CHAR(7)," -Prescription was not "_$SELECT(STATUS=12:"reinstated",1:"discontinued")_"..."
Begin DoDot:1
+17 if '$DATA(PSOCLC)
SET PSOCLC=DUZ
SET MSG=ACT
SET REA=$SELECT(STATUS=12:"R",1:"C")
if $GET(DUP)
SET PSORX("DFLG")=1
KILL DUP
+18 IF $DATA(^TMP("PSORXDC",$JOB,RXREC,0))
KILL ^TMP("PSORXDC",$JOB,RXREC,0)
End DoDot:1
QUIT
+19 SET PSOCLC=DUZ
SET MSG=$SELECT($GET(MSG)]"":MSG,1:ACT_" During New RX "_$SELECT('$GET(PSONV):"Entry",1:"Verification")_" - Duplicate Rx")
SET REA=$SELECT(STATUS=12:"R",1:"C")
+20 WRITE !!,"THERAPEUTIC DUPLICATIONS will be discontinued after the acceptance of the new order.",!!
+21 SET ^TMP("PSORXDC",$JOB,RXREC,0)="52^"_DA_"^"_MSG_"^"_REA_"^"_ACT_"^"_ST_"^"_DRG
SET PSONOOR="D"
+22 KILL RXRECLOC,DUP,CLS,PSONOOR,STATUS,ACT,PSONV,REA,SPCANC
+23 QUIT
+24 ;
DUPCL ;
+1 if $GET(PSODLQT)
QUIT
+2 ;W:'$G(PSODUPF) @IOF,PSONULN1,!
if $GET(PSODUPF)
SET PSODUPC=PSODUPC+1
+3 IF '$GET(PSODUPF)
WRITE "*** THERAPEUTIC DUPLICATION(S) *** "_PSODRUG("NAME")_" with"
+4 if $GET(PSODUPF)
SET PSODUPC=PSODUPC+1
NEW PSODUPCT,PSODUPC2,PSODUPCL
+5 SET (PSODUPC2,PSODUPCT)=0
if '$GET(PSODUPF)
SET PSODUPCT=2
+6 ;displays order and therapy
+7 KILL DDTH
SET (PSODUPCL,ZSUB,ZCT,PSODSEQ)=""
+8 FOR
SET ZCT=$ORDER(ZTHER(ZCT))
if ZCT=""!($GET(PSODLQT))
QUIT
FOR
SET PSODSEQ=$ORDER(ZTHER(ZCT,PSODSEQ))
if PSODSEQ=""!($GET(PSODLQT))
QUIT
SET ON=ZTHER(ZCT,PSODSEQ)
Begin DoDot:1
+9 IF '$GET(PSODUPF)
SET PSOTHND3=PSOTHND3+1
IF 'PSOTHND1
IF '$GET(PSODLQT)
IF $ORDER(ZTHER(ZCT,PSODSEQ))
IF PSOTHND3>1
DO RTC
+10 SET (PDODCNT,PSOTHND1)=0
SET PSODUPC2=PSODUPC2+1
IF $GET(PSODUPF)
SET PSODUPC(ZCT)=0
+11 IF PSODUPC2=PSODUPC2+1
+12 IF '$GET(PSODUPF)
Begin DoDot:2
+13 IF PSODUPC2=PSODUPC1
IF (PSODUPCT+PSODUPC(ZCT)+PSODUPC("CLASS"))>22
DO HD(15)
if $GET(PSODLQT)
QUIT
SET PSODUPCT=0
+14 IF (PSODUPCT+PSODUPC(ZCT))>22
DO HD(15)
if $GET(PSODLQT)
QUIT
SET PSODUPCT=0
+15 SET PSODUPCT=PSODUPCT+PSODUPC(ZCT)
End DoDot:2
+16 IF $PIECE(ON,";")="O"
DO HD()
if $GET(PSODLQT)
QUIT
if $GET(PSODUPF)
SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
if '$GET(PSODUPF)
WRITE !
SET THER=1
DO DDRX^PSODDPR8
Begin DoDot:2
+17 if STATUS>5&(STATUS'=16)
QUIT
+18 if $GET(^TMP("PSORXDC",$JOB,RXREC,0))]""
QUIT
+19 if $GET(RXDT("O",RXREC))
QUIT
+20 SET RX0=^PSRX(RXREC,0)
SET J=RXREC
SET RX2=^PSRX(RXREC,2)
DO STAT^PSOFUNC
KILL RX0,RX2
+21 SET PSOZZ=PSOZZ+1
SET ^TMP($JOB,"PSODCOR",PSOZZ)="52"_"^"_RXREC_"^"_ST_"^"_DRGNM
SET RXDT("O",RXREC)=1
End DoDot:2
+22 IF $PIECE(ON,";")="N"
DO HD()
if $GET(PSODLQT)
QUIT
if $GET(PSODUPF)
SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
if '$GET(PSODUPF)
WRITE !
DO ^PSODDPR3
+23 IF $PIECE(ON,";")="P"
Begin DoDot:2
+24 ; PSO*7*411
+25 DO HD(8)
if $GET(PSODLQT)
QUIT
if $GET(PSODUPF)
SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
if '$GET(PSODUPF)
WRITE !
SET RXREC=$PIECE(ON,";",2)
SET THER=1
DO PEND^PSODDPR8
+26 if $GET(^TMP("PSORXDC",$JOB,RXREC,0))]""
QUIT
+27 if $GET(RXDT("P",RXREC))
QUIT
+28 SET PSOZZ=PSOZZ+1
SET DUPRX0=^PS(52.41,RXREC,0)
+29 SET ^TMP($JOB,"PSODCOR",PSOZZ)="P"_"^"_RXREC_"^^"_$SELECT($PIECE(DUPRX0,"^",9):$PIECE(^PSDRUG($PIECE(DUPRX0,"^",9),0),"^"),1:$PIECE(^PS(50.7,$PIECE(DUPRX0,"^",8),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,$PIECE(DUPRX0,"^
",8),0),"^",2),0),"^"))
+30 SET ^TMP($JOB,"PSODCOR",PSOZZ)=^TMP($JOB,"PSODCOR",PSOZZ)_"^"_$SELECT('$PIECE(DUPRX0,"^",9):$PIECE(^PS(50.7,$PIECE(DUPRX0,"^",8),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,$PIECE(DUPRX0,"^",8),0),"^",2),0),"^"),1:...
... $PIECE(^PSDRUG($PIECE(DUPRX0,"^",9),0),"^"))
+31 SET RXDT("P",RXREC)=1
End DoDot:2
+32 IF $PIECE(ON,";")="R"
if $GET(PSODUPF)
SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
if '$GET(PSODUPF)
WRITE !
DO RDI^PSODDPR3
DO HD()
if $GET(PSODLQT)
QUIT
+33 ; clinic order
IF $EXTRACT($PIECE(ON,";"))="C"
DO HD()
if $GET(PSODLQT)
QUIT
if $GET(PSODUPF)
SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
if '$GET(PSODUPF)
WRITE !
DO DUP^PSODDPR7
+34 IF $ORDER(ZTHER(ZCT,PSODSEQ))'=""
DO HD()
if $GET(PSODLQT)
QUIT
if $GET(PSODUPF)
SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
if '$GET(PSODUPF)
WRITE !,PSONULN
End DoDot:1
+35 DO CLASSES^PSODDPR3
+36 ;format therapy classes pso*7*411
+37 NEW X
SET (ZCT,ZZCT,ZZZCT)=0
+38 FOR
SET ZZCT=$ORDER(^TMP($JOB,LIST,"OUT","THERAPY",ZZCT))
if 'ZZCT
QUIT
SET ZCT=0
FOR
SET ZCT=$ORDER(^TMP($JOB,LIST,"OUT","THERAPY",ZZCT,ZCT))
if 'ZCT
QUIT
Begin DoDot:1
+39 ;S X=^TMP($J,LIST,"OUT","THERAPY",ZZCT,ZCT,"CLASS") ; ME2 - 1602256
+40 SET X=^TMP($JOB,LIST,"OUT","THERAPY",ZZCT,ZCT,"CLASS")_$SELECT($ORDER(^TMP($JOB,LIST,"OUT","THERAPY",ZZCT))!($ORDER(^TMP($JOB,LIST,"OUT","THERAPY",ZZCT,ZCT))):", ",1:"")
End DoDot:1
+41 if $GET(PSODLQT)!($DATA(^XUSEC("PSORPH",DUZ)))
QUIT
+42 IF '$GET(PSODUPF)
IF '$DATA(^XUSEC("PSORPH",DUZ))
Begin DoDot:1
+43 SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
WRITE @IOF
+44 IF '$GET(PSODUPF)
IF Y'=1!($DATA(DTOUT))!($DATA(DUOUT))
SET PSODLQT=1
SET PSORX("DFLG")=1
QUIT
+45 IF '$GET(PSODUPF)
IF ($Y+5)>IOSL
WRITE @IOF
End DoDot:1
+46 QUIT
INT ;
+1 if $DATA(PSSDIUTL)
QUIT
+2 DO INT^PSODDPR5
+3 QUIT
HD(PSOLINES,OVRRID) ;
+1 ;P634
if $GET(PSODUPF)
QUIT
+2 if '$GET(PSODLQT)
SET PSODLQT=0
if '$GET(OVRRID)
SET OVRRID=0
if '$GET(PSOLINES)
SET PSOLINES=5
+3 IF '$GET(OVRRID)
IF $GET(PSODLQT)!(($Y+PSOLINES)'>IOSL)
QUIT
+4 IF $GET(PSOTHND2)
SET PSOTHND1=1
+5 NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
+6 WRITE !
KILL DIR,Y
SET DIR(0)="E"
SET DIR("A")="Press return to continue"
DO ^DIR
KILL DIR
+7 KILL PSOLINES,OVRRID
+8 IF Y'=1!($DATA(DTOUT))!($DATA(DUOUT))
SET PSODLQT=1
SET PSORX("DFLG")=1
QUIT
+9 if '$GET(PSODUPF)
WRITE @IOF
+10 QUIT
+11 ;
DGSORT ;
+1 ;this sort is used in monograph and clinic effects display so that they are displayed once per VA generic drug
+2 SET (SEV,TYP,PSOVAG,PSONAM)=""
FOR
SET SEV=$ORDER(ZZDGDG3(SEV))
if SEV=""
QUIT
FOR
SET PSOVAG=$ORDER(ZZDGDG3(SEV,PSOVAG))
if PSOVAG=""
QUIT
Begin DoDot:1
+3 SET COUNT2=0
FOR
SET PSONAM=$ORDER(ZZDGDG3(SEV,PSOVAG,PSONAM))
if PSONAM=""
QUIT
SET COUNT2=COUNT2+1
SET ZZDGDG2(SEV,PSOVAG)=COUNT2
End DoDot:1
+4 KILL COUNT2,PSONAM
+5 QUIT
+6 ;
+7 ;
RTC ;Return to continue
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
SET DIR(0)="EA"
SET DIR("A")="Press Return to Continue: "
DO ^DIR
KILL DIR
WRITE @IOF
+2 QUIT
