- 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 Jan 18, 2025@03:27:34 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