- PSODDPRE ; BIR/SAB - Enhanced OP order checks ;09/20/06 3:38pm
- ;;7.0;OUTPATIENT PHARMACY;**251,375,387,379,390,372,416,411,518,568,768**;DEC 1997;Build 12
- ;External reference to PSOL^PSSLOCK supported by DBIA 2789
- ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
- ;External reference to ^PSSDSAPM supported by DBIA 5570
- ;External reference to ^PSSHRQ2 supported by DBIA 5369
- ;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 4846
- ;External reference to ^PS(50.606 supported by DBIA 2174
- ;External reference to $$SUP^PSSDSAPI supported by DBIA 5425
- ;External reference to ^PSSDIUTL supported by DBIA 5737
- ;
- W @IOF
- K IT,^TMP("PSORXDC",$J),^TMP("PSORXDD",$J),CLS,^TMP($J,"PSONVADD"),^TMP($J,"PSONRVADD"),^TMP($J,"PSORDI"),^TMP($J,"PSORMDD")
- N PSONULN,PSODLQT,ZZPSODRG S LIST="PSOPEPS",$P(PSONULN,"-",79)="-",(STA,DNM)=""
- D HD^PSODDPR2():(($Y+5)>IOSL) Q:$G(PSODLQT)
- F S STA=$O(PSOSD(STA)) Q:STA="" F S DNM=$O(PSOSD(STA,DNM)) Q:DNM=""!$G(PSORX("DFLG")) I $P(PSOSD(STA,DNM),"^")'=$G(PSORENW("OIRXN")) D Q:$G(PSORX("DFLG"))
- .I STA="PENDING" D ^PSODDPR1 Q
- .I STA="ZNONVA" D NVA^PSODDPR1 Q
- .D:PSODRUG("NAME")=$P(DNM,"^")&('$D(^XUSEC("PSORPH",DUZ))) Q:$G(PSORX("DFLG"))
- ..I '$P(PSOPAR,"^",2),'$P(PSOPAR,"^",16) D DUP I $G(PSOTECCK) S PSORX("DFLG")=1 Q
- ..I '$P(PSOPAR,"^",2),$P(PSOPAR,"^",16),$G(PSOTECCK) D DUP Q
- ..I $P(PSOPAR,"^",2),$G(PSOTECCK) D Q
- ...S DA=+PSOSD(STA,DNM),PSOCLC=DUZ
- ...S MSG="Discontinued During Reinstating Prescription Entry",ACT="Discontinued during Rx Reinstate."
- ...S ^TMP("PSORXDC",$J,DA,0)="52^"_DA_"^"_MSG_"^C^"_ACT_"^"_STA_"^"_DNM,PSONOOR="D",^TMP("PSORXDD",$J)=DNM
- ..I $P($G(PSOPAR),"^",16) D DUP Q
- ..I $P(PSOPAR,"^",2),'$P(PSOPAR,"^",16) D DUP S PSORX("DFLG")=1 Q
- .D:PSODRUG("NAME")=$P(DNM,"^")&($D(^XUSEC("PSORPH",DUZ))) DUP
- K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI"),^TMP($J,"PSODRDI")
- Q:$G(PSORX("DFLG"))
- M ZZPSODRG=PSODRUG
- S LIST="PSOPEPS" D REMOTE^PSOCPPRE
- M PSODRUG=ZZPSODRG
- Q
- OBX ;process enhanced order checks
- Q:$G(PSOQUIT)!($G(PSORX("DFLG")))
- K ZDGDG,ZTHER,IT
- S LIST="PSOPEPS" K PSODLQT,DTOUT,DUOUT,DIRUT,PSODOSD
- I $P(^TMP($J,LIST,"OUT",0),"^")=-1 G EXIT
- W !,"Now Processing Enhanced Order Checks! Please wait...",! H 2
- D FDB S PDRG=PSODRUG("IEN"),DO=0 D IN^PSSHRQ2(LIST) ;call 2 fdb
- ;
- K DIR
- I $P(^TMP($J,LIST,"OUT",0),"^")=-1 D DATACK G EXIT
- I '$D(PSODGCK) D ^PSODDPR2 ;if order checks returned
- I $D(PSODGCK) D PROC^PSSDIUTL Q ;if running DX option
- I '$G(PSOCOPY)&('$G(PSORENW)),$G(PSOQUIT) D
- .I $G(PSOREINS) Q:$G(PSODLQT) S PSORX("DFLG")=1
- ;
- EXIT ;
- D ^PSOBUILD
- K 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
- K DO,PDRG,IT,PSODLQT,PSOTSTMD
- K ^TMP($J,LIST,"IN","PING"),^TMP($J,LIST,"OUT","EXCEPTIONS"),^TMP($J,"PSOPEPS"),^TMP($J,"PSORDI")
- Q
- DUP S:$P(PSOSD(STA,DNM),"^",2)<10!($P(PSOSD(STA,DNM),"^",2)=16) DUP=1 W !,PSONULN,!,$C(7),"Duplicate Drug in Local Rx:",!
- S RXREC=+PSOSD(STA,DNM),MSG="Discontinued During "_$S('$G(PSONV):"New Prescription Entry",1:"Verification")_" - Duplicate Drug"
- DATA S DUPRX0=^PSRX(RXREC,0),RFLS=$P(DUPRX0,"^",9),ISSD=$P(^PSRX(RXREC,0),"^",13),RX0=DUPRX0,RX2=^PSRX(RXREC,2),$P(RX0,"^",15)=+$G(^PSRX(RXREC,"STA"))
- S RXRECLOC=$G(RXREC)
- S DA=RXREC
- D HD^PSODDPR2():(($Y+5)>IOSL) Q:$G(PSODLQT)
- W !,$J("Rx: ",24)_$P(^PSRX(+PSOSD(STA,DNM),0),"^")
- W !,$J("Drug: ",24)_$P(DNM,"^")
- K FSIG,BSIG I $P($G(^PSRX(RXREC,"SIG")),"^",2) D FSIG^PSOUTLA("R",RXREC,54) F PSREV=1:1 Q:'$D(FSIG(PSREV)) S BSIG(PSREV)=FSIG(PSREV)
- K FSIG,PSREV I '$P($G(^PSRX(RXREC,"SIG")),"^",2) D EN2^PSOUTLA1(RXREC,54)
- W !,$J("SIG: ",24) W $G(BSIG(1))
- I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV W !?24,$G(BSIG(PSREV))
- K BSIG,PSREV
- D HD^PSODDPR2():(($Y+5)>IOSL) Q:$G(PSODLQT)
- W !,$J("QTY: ",24)_$P(DUPRX0,"^",7),?42,$J("Refills remaining: ",24),RFLS-$S($D(^PSRX(RXREC,1,0)):$P(^(0),"^",4),1:0)
- S PHYS=$S($D(^VA(200,+$P(DUPRX0,"^",4),0)):$P(^(0),"^"),1:"UNKNOWN")
- W !,$J("Provider: ",24)_PHYS,?42,$J("Issued: ",24),$E(ISSD,4,5)_"/"_$E(ISSD,6,7)_"/"_$E(ISSD,2,3)
- W !,$J("Status: ",24) S J=RXREC D STAT^PSOFUNC W ST K RX0,RX2
- S LSTFL=+^PSRX(RXREC,3) W ?42,$J("Last filled: ",24)_$E(LSTFL,4,5)_"/"_$E(LSTFL,6,7)_"/"_$E(LSTFL,2,3)
- D PRSTAT(RXREC)
- W !?42,$J("Days Supply: ",24)_$P(DUPRX0,"^",8)
- W !,PSONULN,! 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
- ASKCAN I $P(PSOSD(STA,DNM),"^",2)>10,$P(PSOSD(STA,DNM),"^",2)'=16 D Q ;PSO*7*411 to comment
- .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,PSORX("DFLG"))=1 K DIR,DTOUT,DUOUT,DIRUT,RXRECLOC W @IOF
- .S ^TMP("PSORXDD",$J,RXREC,0)=1
- ;
- I '$P(PSOPAR,"^",16),'$D(^XUSEC("PSORPH",DUZ)) D Q
- .S PSORX("DFLG")=1 K RXRECLOC,DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue"
- .D ^DIR K DIR
- I $P(PSOSD(STA,DNM),"^",2)=16,$G(DUP) D Q
- .W !!,"Prescription "_$P($G(^PSRX(+$G(RXRECLOC),0)),"^")_" is on Provider Hold, it cannot be discontinued.",!
- .K DUP,DIR,RXRECLOC S PSORX("DFLG")=1 S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR K DIR
- 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(RXRECLOC,0)),"^"),!
- I $D(PSODGCK) K RXRECLOC,DUP,CLS,PSONOOR Q
- K PSOMSG S DIR("A")=$S($P(PSOSD(STA,DNM),"^",2)=12:"Reinstate",1:"Discontinue")_" RX # "_$P(^PSRX(+PSOSD(STA,DNM),0),"^")_" "_$P(DNM,"^")_" Y/N",DIR(0)="Y"
- S DIR("?")="Enter Y to "_$S($P(PSOSD(STA,DNM),"^",2)=12:"reinstate",1:"discontinue")_" this RX."
- D ^DIR K DIR S DA=RXREC S ACT=$S($D(SPCANC):"Reinstated during Rx cancel.",1:$S($P(PSOSD(STA,DNM),"^",2)=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($P(PSOSD(STA,DNM),"^",2)=12:"reinstated",1:"discontinued")_"..." D Q
- .S:'$D(PSOCLC) PSOCLC=DUZ S MSG=ACT,REA=$S($P(PSOSD(STA,DNM),"^",2)=12:"R",1:"C") S:$G(DUP) PSORX("DFLG")=1 K DUP D ULRX K RXRECLOC
- .K ^TMP("PSORXDC",$J,RXREC,0)
- I $P(PSOSD(STA,DNM),"^",2)=16,$G(CLS) W !!,"Prescription "_$P($G(^PSRX(+$G(RXRECLOC),0)),"^")_" is on Provider Hold, it cannot be discontinued.",! D ULRX K CLS,DUP,RXRECLOC S PSORX("DFLG")=1 H 2 Q
- S PSOCLC=DUZ,MSG=$S($G(MSG)]"":MSG,1:ACT_" During New RX "_$S('$G(PSONV):"Entry",1:"Verification")_" - Duplicate Rx"),REA=$S($P(PSOSD(STA,DNM),"^",2)=12:"R",1:"C")
- W !! K ^UTILITY($J,"W") S DIWL=1,DIWR=75,DIWF=""
- S X="Rx #"_$P(^PSRX(+PSOSD(STA,DNM),0),"^")_" "_DNM_" will be discontinued after"_$S('$G(PSOTECCK):" the acceptance of the new order.",1:" reinstating the order.") D ^DIWP
- N ZX F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W !,^UTILITY($J,"W",1,ZX,0)
- K ^UTILITY($J,"W"),X,DIWL,DIWR,DIWF W !
- S ^TMP("PSORXDC",$J,RXREC,0)="52^"_DA_"^"_MSG_"^"_REA_"^"_ACT_"^"_STA_"^"_DNM,PSONOOR="D",^TMP("PSORXDD",$J)=DNM H 2
- K RXRECLOC,DUP,CLS,PSONOOR
- Q
- FDB ;build drug check input
- N ID,ORTYP,PSOI,ORN S DFN=PSODFN,CT=0
- S ID=+$$GETVUID^XTID(50.68,,+$P(PSODRUG("NDF"),"A",2)_",")
- S P1=$P(PSODRUG("NDF"),"A"),P2=$P(PSODRUG("NDF"),"A",2),X=$$PROD0^PSNAPIS(P1,P2),SEQN=+$P(X,"^",7)
- I 'SEQN K ^TMP($J,LIST,"OUT","EXCEPTIONS")
- S ^TMP($J,LIST,"IN","PROSPECTIVE","Z;1;PROSPECTIVE;1")=SEQN_"^"_ID_"^"_PSODRUG("IEN")_"^"_$P(^PSDRUG(PSODRUG("IEN"),0),"^")
- I $G(PSODGCKX) K ^TMP($J,LIST,"IN","PROSPECTIVE","Z;1;PROSPECTIVE;1")
- S ^TMP($J,LIST,"IN","IEN")=PSODFN,^TMP($J,LIST,"IN","DRUGDRUG")="",^TMP($J,LIST,"IN","THERAPY")=""
- K ID,P1,P2 N ODRG,TU S (STA,DNM)="" I '$G(PSOCOPY),'$G(SEQN),'$G(PSODGCK) K SEQN Q
- ;build profile drug order checks
- F S STA=$O(PSOSD(STA)) Q:STA="" F S DNM=$O(PSOSD(STA,DNM)) Q:DNM="" D
- .Q:$P(PSOSD(STA,DNM),"^")=$G(PSORENW("OIRXN"))&('$G(PSOCOPY))
- .S CT=CT+1
- .I STA="PENDING" N DDRG D
- ..Q:$G(^TMP("PSORXDC",$J,$P(PSOSD(STA,DNM),"^",10),0))]""
- ..Q:$G(PSODRUG("IEN"))=$P(^PS(52.41,$P(PSOSD(STA,DNM),"^",10),0),"^",9)
- ..Q:$P(^PS(52.41,$P(PSOSD(STA,DNM),"^",10),0),"^",3)="RF"
- ..Q:$G(^TMP("PSORXPO",$J,$P(PSOSD(STA,DNM),"^",10),0))
- ..S RXREC=$P(PSOSD(STA,DNM),"^",10),ORN=$P(^PS(52.41,RXREC,0),"^"),ODRG=$P(^(0),"^",9),ORTYP="P"
- ..I ODRG D K ODRG Q
- ...I $P($G(^PSDRUG(ODRG,0)),"^",3)["S"!($E($P($G(^PSDRUG(ODRG,0)),"^",2),1,2)="XA") Q
- ...S PDNM=$P(^PSDRUG(ODRG,0),"^") D ID
- ..E N PSOI,DDRG,ODRG,SEQN,DDRG S PSOI=$P(^PS(52.41,RXREC,0),"^",8) D
- ...S PDNM=$P(^PS(50.7,PSOI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")
- ...S DDRG=$$DRG^PSSDSAPM(PSOI,"O") I '$P(DDRG,";") D:'$$NVATST(PSOI,"O") OIX Q
- ...I $P($G(^PSDRUG($P(DDRG,";"),0)),"^",3)["S"!($E($P($G(^PSDRUG($P(DDRG,";"),0)),"^",2),1,2)="XA") Q
- ...S ODRG=$P(DDRG,";"),SEQN=+$P(DDRG,";",3) K PSOI
- ...N ID S ID=+$$GETVUID^XTID(50.68,,+$P($G(^PSDRUG(ODRG,"ND")),"^",3)_",")
- ...D ID1
- .I STA="ZNONVA" D Q
- ..Q:$G(^TMP($J,"PSONVADD",$P(PSOSD(STA,DNM),"^",10),0))]""
- ..S RXREC=$P(PSOSD(STA,DNM),"^",10),ODRG=$P(^PS(55,PSODFN,"NVA",RXREC,0),"^",2),ORN=$P(^(0),"^",8),ORTYP="N"
- ..I ODRG D K ODRG Q
- ...I $P($G(^PSDRUG(ODRG,0)),"^",3)["S"!($E($P($G(^PSDRUG(ODRG,0)),"^",2),1,2)="XA") Q
- ...S PDNM=$P(^PSDRUG(ODRG,0),"^") S:CT=1&($G(PSODGCK))&('$G(PSODGCKX)) CT=2 D ID ;CT=2 prevents overwrite of CK action drug prompt reply
- ..E N PSOI,DDRG,ODRG,SEQN,DDRG S PSOI=$P(^PS(55,PSODFN,"NVA",RXREC,0),"^") D
- ...S PDNM=$P(^PS(50.7,PSOI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")
- ...S DDRG=$$DRG^PSSDSAPM(PSOI,"X") I '$P(DDRG,";") D:'$$NVATST(PSOI,"X") OIX Q
- ...I $P($G(^PSDRUG($P(DDRG,";"),0)),"^",3)["S"!($E($P($G(^PSDRUG($P(DDRG,";"),0)),"^",2),1,2)="XA") Q
- ...S ODRG=$P(DDRG,";"),SEQN=+$P(DDRG,";",3) K PSOI
- ...N ID S ID=+$$GETVUID^XTID(50.68,,+$P($G(^PSDRUG(ODRG,"ND")),"^",3)_",")
- ...I CT=1,$G(PSODGCK),'$G(PSODGCKX) S CT=2 ;prevents overwrite of CK action drug prompt reply
- ...D ID1
- .I $P($G(^PSRX(+PSOSD(STA,DNM),0)),"^",6) D
- ..Q:$G(^TMP("PSORXDC",$J,$P(PSOSD(STA,DNM),"^"),0))]""
- ..Q:$G(^TMP("PSORXBO",$J,$P(PSOSD(STA,DNM),"^"),0))
- ..Q:$G(^TMP("PSORXDD",$J,$P(PSOSD(STA,DNM),"^"),0))
- ..;I $P(PSOSD(STA,DNM),"^",2)>5,$P(PSOSD(STA,DNM),"^",2)'=16 Q
- ..S RXREC=+PSOSD(STA,DNM),ODRG=$P(^PSRX(RXREC,0),"^",6),ORN=$P($G(^("OR1")),"^",2),ORTYP="O"
- ..I ODRG D
- ...I $P($G(^PSDRUG(ODRG,0)),"^",3)["S"!($E($P($G(^PSDRUG(ODRG,0)),"^",2),1,2)="XA") Q
- ...I STA="DISCONTINUED" Q:$$DUPTHER(RXREC)
- ...S PDNM=$P(^PSDRUG(ODRG,0),"^") D ID
- D IMO^PSODDPR7(PSODFN)
- K RXREC,ID,STA,DNM,PSOI,ORN,ODRG,ORTYP,CT,PDNM,TU,DDRG
- Q
- ;
- ID N ID,P1,P2,PSODGCKP S ID=+$$GETVUID^XTID(50.68,,+$P($G(^PSDRUG(ODRG,"ND")),"^",3)_",")
- S P1=$P($G(^PSDRUG(ODRG,"ND")),"^"),P2=$P($G(^("ND")),"^",3),X=$$PROD0^PSNAPIS(P1,P2),SEQN=$P(X,"^",7)
- ID1 S PSODGCKP=$S($G(PSODGCK):"PROSPECTIVE",1:"PROFILE")
- S ^TMP($J,LIST,"IN",PSODGCKP,$S($D(PSODGCK):"Z",1:ORTYP)_";"_RXREC_";"_PSODGCKP_";"_CT)=SEQN_"^"_ID_"^"_ODRG_"^"_PDNM_"^"_ORN_"^O" K ID
- Q
- DUPTHER(RXREC) ;screen out discontinued/duplicate therapy Rx's greater than business rule calculation (cancel date + days supply +7 days)
- ;Note: If the dup allowance is 1 you have to have at least 3 eligible drug orders (or 2 matches) to produce the dupl. therapy warning
- ;Business rule for expired orders is (expiration date+120 days) which is the length of time expired order currently stay on med profile. No changes for this.
- N X,Y,X1,X2 S X1=$P($G(^PSRX(RXREC,3)),"^",5),X2=(+$P(^PSRX(RXREC,0),"^",8)+7) D C^%DTC I DT>X Q 1
- Q 0
- OIX S ^TMP($J,LIST,"IN","EXCEPTIONS","OI",PDNM)=1_"^"_ORTYP_";"_RXREC_";PROFILE;"_CT
- Q
- ULRX ;
- I '$G(RXRECLOC) Q
- D PSOUL^PSSLOCK(RXRECLOC)
- Q
- ;
- PRSTAT(DA) ;Displays the prescription's status
- N PSOTRANS,PSOREL,PSOCMOP,RXPSTA,PSOX,RFLZRO,PSOLRD,PSORTS,CMOP,PSORFL,PSOMW
- D HD^PSODDPR2():(($Y+5)>IOSL) Q:$G(PSODLQT) ;PSO*7*411 to comment
- S RXPSTA="Processing Status: ",PSOLRD=$P($G(^PSRX(RXREC,2)),"^",13)
- ;
- D ^PSOCMOPA I $G(PSOCMOP)]"" D K CMOP,PSOTRANS,PSOREL
- .S PSOTRANS=$E($P(PSOCMOP,"^",2),4,5)_"/"_$E($P(PSOCMOP,"^",2),6,7)_"/"_$E($P(PSOCMOP,"^",2),2,3)
- .S PSOREL=$S(CMOP("L")=0:$P($G(^PSRX(DA,2)),"^",13),1:$P(^PSRX(DA,1,CMOP("L"),0),"^",18))
- .S PSOREL=$E(PSOREL,4,5)_"/"_$E(PSOREL,6,7)_"/"_$E(PSOREL,2,3)_"@"_$E($P(PSOREL,".",2),1,4)
- .I '$D(IOINORM)!('$D(IOINHI)) S X="IORVOFF;IORVON;IOINHI;IOINORM" D ENDR^%ZISS
- .I $P($G(^PSRX(RXREC,"STA")),"^")=0 W:$$TRANCMOP^PSOUTL(RXREC) ?5,IORVON_IOINHI
- .S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1
- .W:'$G(PSODUPF) !,$J(RXPSTA,24)_$S($P(PSOCMOP,"^")=0!($P(PSOCMOP,"^")=2):"Transmitted to CMOP on "_PSOTRANS,$P(PSOCMOP,"^")=1:"Released by CMOP on "_PSOREL,$P(PSOCMOP,"^")=3&(PSOLRD):"Dispensed locally NOT by CMOP",1:"Not Dispensed")
- .W:'$G(PSODUPF) IOINORM_IORVOFF
- D HD^PSODDPR2():(($Y+5)>IOSL) Q:$G(PSODLQT)
- I $G(PSOCMOP)']"" D
- .S PSORFL=0
- .F PSOX=0:0 S PSOX=$O(^PSRX(RXREC,1,PSOX)) Q:'PSOX D
- ..S PSORFL=PSOX ;PSO*7*768
- ..S RFLZRO=$G(^PSRX(RXREC,1,PSOX,0))
- ..S:$P(RFLZRO,"^",18)'="" PSOLRD=$P(RFLZRO,"^",18) I $P(RFLZRO,"^",16) S PSOLRD=PSOLRD_"^R",PSORTS=$P(RFLZRO,"^",16)
- .I '$O(^PSRX(RXREC,1,0)),$P(^PSRX(RXREC,2),"^",15) S PSOLRD=PSOLRD_"^R",PSORTS=$P(^PSRX(RXREC,2),"^",15)
- .S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) !,$J(RXPSTA,24)
- .I +$G(PSORTS) S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) "Returned to stock on "_$$FMTE^XLFDT(PSORTS,2) Q
- .S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1
- .;PSO*7*768
- .S PSOMW=""
- .I PSORFL S PSOMW=$S($P(^PSRX(RXREC,1,PSORFL,0),"^",2)="W":" (Window)",1:" (Mail)")
- .I PSOMW="" S PSOMW=$S($P(^PSRX(RXREC,0),"^",11)="W":" (Window)",1:" (Mail)")
- .W:'$G(PSODUPF) $S(PSOLRD="":"Not released locally",1:"Released locally on "_$$FMTE^XLFDT($P(PSOLRD,"^"),2)_" "_$P(PSOLRD,"^",2))_PSOMW
- Q
- ;
- DATACK ;check FDB returned data to determine whether to continue processing.
- S DIR(0)="E",DIR("A",1)="No Enhanced Order Checks can be performed."
- S DIR("A",2)=" Reason(s): "_$P($G(^TMP($J,LIST,"OUT",0)),"^",2)
- S DIR("A")="Press Return to continue...",DIR("?")="Press Return to continue"
- W ! D ^DIR K DIRUT,DUOUT,DIR,X,Y W @IOF ;I $P(^TMP($J,LIST,"OUT",0),"^")=1
- Q
- ;
- NVATST(PSONVTOI,PSONVTAP) ; Look for any active Non-VA Dispense Drugs not marked as a supply item
- N PSONVT1,PSONVTFL,PSONVTIN
- S PSONVTFL=1
- F PSONVT1=0:0 S PSONVT1=$O(^PSDRUG("ASP",PSONVTOI,PSONVT1)) Q:'PSONVT1!('PSONVTFL) D
- .I $P($G(^PSDRUG(PSONVT1,2)),"^",3)'[PSONVTAP Q
- .S PSONVTIN=$P($G(^PSDRUG(PSONVT1,"I")),"^") I PSONVTIN,PSONVTIN<DT Q
- .S PSONVTFL=$$SUP^PSSDSAPI(PSONVT1)
- Q PSONVTFL
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODDPRE 15102 printed Feb 18, 2025@23:52:58 Page 2
- PSODDPRE ; BIR/SAB - Enhanced OP order checks ;09/20/06 3:38pm
- +1 ;;7.0;OUTPATIENT PHARMACY;**251,375,387,379,390,372,416,411,518,568,768**;DEC 1997;Build 12
- +2 ;External reference to PSOL^PSSLOCK supported by DBIA 2789
- +3 ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
- +4 ;External reference to ^PSSDSAPM supported by DBIA 5570
- +5 ;External reference to ^PSSHRQ2 supported by DBIA 5369
- +6 ;External reference to ^PS(50.7 supported by DBIA 2223
- +7 ;External reference to ^PS(55 supported by DBIA 2228
- +8 ;External reference to ^PSDRUG( supported by DBIA 4846
- +9 ;External reference to ^PS(50.606 supported by DBIA 2174
- +10 ;External reference to $$SUP^PSSDSAPI supported by DBIA 5425
- +11 ;External reference to ^PSSDIUTL supported by DBIA 5737
- +12 ;
- +13 WRITE @IOF
- +14 KILL IT,^TMP("PSORXDC",$JOB),^TMP("PSORXDD",$JOB),CLS,^TMP($JOB,"PSONVADD"),^TMP($JOB,"PSONRVADD"),^TMP($JOB,"PSORDI"),^TMP($JOB,"PSORMDD")
- +15 NEW PSONULN,PSODLQT,ZZPSODRG
- SET LIST="PSOPEPS"
- SET $PIECE(PSONULN,"-",79)="-"
- SET (STA,DNM)=""
- +16 if (($Y+5)>IOSL)
- DO HD^PSODDPR2()
- if $GET(PSODLQT)
- QUIT
- +17 FOR
- SET STA=$ORDER(PSOSD(STA))
- if STA=""
- QUIT
- FOR
- SET DNM=$ORDER(PSOSD(STA,DNM))
- if DNM=""!$GET(PSORX("DFLG"))
- QUIT
- IF $PIECE(PSOSD(STA,DNM),"^")'=$GET(PSORENW("OIRXN"))
- Begin DoDot:1
- +18 IF STA="PENDING"
- DO ^PSODDPR1
- QUIT
- +19 IF STA="ZNONVA"
- DO NVA^PSODDPR1
- QUIT
- +20 if PSODRUG("NAME")=$PIECE(DNM,"^")&('$DATA(^XUSEC("PSORPH",DUZ)))
- Begin DoDot:2
- +21 IF '$PIECE(PSOPAR,"^",2)
- IF '$PIECE(PSOPAR,"^",16)
- DO DUP
- IF $GET(PSOTECCK)
- SET PSORX("DFLG")=1
- QUIT
- +22 IF '$PIECE(PSOPAR,"^",2)
- IF $PIECE(PSOPAR,"^",16)
- IF $GET(PSOTECCK)
- DO DUP
- QUIT
- +23 IF $PIECE(PSOPAR,"^",2)
- IF $GET(PSOTECCK)
- Begin DoDot:3
- +24 SET DA=+PSOSD(STA,DNM)
- SET PSOCLC=DUZ
- +25 SET MSG="Discontinued During Reinstating Prescription Entry"
- SET ACT="Discontinued during Rx Reinstate."
- +26 SET ^TMP("PSORXDC",$JOB,DA,0)="52^"_DA_"^"_MSG_"^C^"_ACT_"^"_STA_"^"_DNM
- SET PSONOOR="D"
- SET ^TMP("PSORXDD",$JOB)=DNM
- End DoDot:3
- QUIT
- +27 IF $PIECE($GET(PSOPAR),"^",16)
- DO DUP
- QUIT
- +28 IF $PIECE(PSOPAR,"^",2)
- IF '$PIECE(PSOPAR,"^",16)
- DO DUP
- SET PSORX("DFLG")=1
- QUIT
- End DoDot:2
- if $GET(PSORX("DFLG"))
- QUIT
- +29 if PSODRUG("NAME")=$PIECE(DNM,"^")&($DATA(^XUSEC("PSORPH",DUZ)))
- DO DUP
- End DoDot:1
- if $GET(PSORX("DFLG"))
- QUIT
- +30 KILL ^TMP($JOB,"DD"),^TMP($JOB,"DC"),^TMP($JOB,"DI"),^TMP($JOB,"PSODRDI")
- +31 if $GET(PSORX("DFLG"))
- QUIT
- +32 MERGE ZZPSODRG=PSODRUG
- +33 SET LIST="PSOPEPS"
- DO REMOTE^PSOCPPRE
- +34 MERGE PSODRUG=ZZPSODRG
- +35 QUIT
- OBX ;process enhanced order checks
- +1 if $GET(PSOQUIT)!($GET(PSORX("DFLG")))
- QUIT
- +2 KILL ZDGDG,ZTHER,IT
- +3 SET LIST="PSOPEPS"
- KILL PSODLQT,DTOUT,DUOUT,DIRUT,PSODOSD
- +4 IF $PIECE(^TMP($JOB,LIST,"OUT",0),"^")=-1
- GOTO EXIT
- +5 WRITE !,"Now Processing Enhanced Order Checks! Please wait...",!
- HANG 2
- +6 ;call 2 fdb
- DO FDB
- SET PDRG=PSODRUG("IEN")
- SET DO=0
- DO IN^PSSHRQ2(LIST)
- +7 ;
- +8 KILL DIR
- +9 IF $PIECE(^TMP($JOB,LIST,"OUT",0),"^")=-1
- DO DATACK
- GOTO EXIT
- +10 ;if order checks returned
- IF '$DATA(PSODGCK)
- DO ^PSODDPR2
- +11 ;if running DX option
- IF $DATA(PSODGCK)
- DO PROC^PSSDIUTL
- QUIT
- +12 IF '$GET(PSOCOPY)&('$GET(PSORENW))
- IF $GET(PSOQUIT)
- Begin DoDot:1
- +13 IF $GET(PSOREINS)
- if $GET(PSODLQT)
- QUIT
- SET PSORX("DFLG")=1
- End DoDot:1
- +14 ;
- EXIT ;
- +1 DO ^PSOBUILD
- +2 KILL 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
- +3 KILL DO,PDRG,IT,PSODLQT,PSOTSTMD
- +4 KILL ^TMP($JOB,LIST,"IN","PING"),^TMP($JOB,LIST,"OUT","EXCEPTIONS"),^TMP($JOB,"PSOPEPS"),^TMP($JOB,"PSORDI")
- +5 QUIT
- DUP if $PIECE(PSOSD(STA,DNM),"^",2)<10!($PIECE(PSOSD(STA,DNM),"^",2)=16)
- SET DUP=1
- WRITE !,PSONULN,!,$CHAR(7),"Duplicate Drug in Local Rx:",!
- +1 SET RXREC=+PSOSD(STA,DNM)
- SET MSG="Discontinued During "_$SELECT('$GET(PSONV):"New Prescription Entry",1:"Verification")_" - Duplicate Drug"
- DATA 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 $PIECE(RX0,"^",15)=+$GET(^PSRX(RXREC,"STA"))
- +1 SET RXRECLOC=$GET(RXREC)
- +2 SET DA=RXREC
- +3 if (($Y+5)>IOSL)
- DO HD^PSODDPR2()
- if $GET(PSODLQT)
- QUIT
- +4 WRITE !,$JUSTIFY("Rx: ",24)_$PIECE(^PSRX(+PSOSD(STA,DNM),0),"^")
- +5 WRITE !,$JUSTIFY("Drug: ",24)_$PIECE(DNM,"^")
- +6 KILL FSIG,BSIG
- IF $PIECE($GET(^PSRX(RXREC,"SIG")),"^",2)
- DO FSIG^PSOUTLA("R",RXREC,54)
- FOR PSREV=1:1
- if '$DATA(FSIG(PSREV))
- QUIT
- SET BSIG(PSREV)=FSIG(PSREV)
- +7 KILL FSIG,PSREV
- IF '$PIECE($GET(^PSRX(RXREC,"SIG")),"^",2)
- DO EN2^PSOUTLA1(RXREC,54)
- +8 WRITE !,$JUSTIFY("SIG: ",24)
- WRITE $GET(BSIG(1))
- +9 IF $ORDER(BSIG(1))
- FOR PSREV=1:0
- SET PSREV=$ORDER(BSIG(PSREV))
- if 'PSREV
- QUIT
- WRITE !?24,$GET(BSIG(PSREV))
- +10 KILL BSIG,PSREV
- +11 if (($Y+5)>IOSL)
- DO HD^PSODDPR2()
- if $GET(PSODLQT)
- QUIT
- +12 WRITE !,$JUSTIFY("QTY: ",24)_$PIECE(DUPRX0,"^",7),?42,$JUSTIFY("Refills remaining: ",24),RFLS-$SELECT($DATA(^PSRX(RXREC,1,0)):$PIECE(^(0),"^",4),1:0)
- +13 SET PHYS=$SELECT($DATA(^VA(200,+$PIECE(DUPRX0,"^",4),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
- +14 WRITE !,$JUSTIFY("Provider: ",24)_PHYS,?42,$JUSTIFY("Issued: ",24),$EXTRACT(ISSD,4,5)_"/"_$EXTRACT(ISSD,6,7)_"/"_$EXTRACT(ISSD,2,3)
- +15 WRITE !,$JUSTIFY("Status: ",24)
- SET J=RXREC
- DO STAT^PSOFUNC
- WRITE ST
- KILL RX0,RX2
- +16 SET LSTFL=+^PSRX(RXREC,3)
- WRITE ?42,$JUSTIFY("Last filled: ",24)_$EXTRACT(LSTFL,4,5)_"/"_$EXTRACT(LSTFL,6,7)_"/"_$EXTRACT(LSTFL,2,3)
- +17 DO PRSTAT(RXREC)
- +18 WRITE !?42,$JUSTIFY("Days Supply: ",24)_$PIECE(DUPRX0,"^",8)
- +19 WRITE !,PSONULN,!
- 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
- ASKCAN ;PSO*7*411 to comment
- IF $PIECE(PSOSD(STA,DNM),"^",2)>10
- IF $PIECE(PSOSD(STA,DNM),"^",2)'=16
- Begin DoDot:1
- +1 KILL DIR
- SET DIR(0)="E"
- SET DIR("?")="Press Return to continue"
- SET DIR("A")="Press Return to continue"
- +2 DO ^DIR
- if ($DATA(DTOUT))!($DATA(DUOUT))
- SET (PSODLQT,PSORX("DFLG"))=1
- KILL DIR,DTOUT,DUOUT,DIRUT,RXRECLOC
- WRITE @IOF
- +3 SET ^TMP("PSORXDD",$JOB,RXREC,0)=1
- End DoDot:1
- QUIT
- +4 ;
- +5 IF '$PIECE(PSOPAR,"^",16)
- IF '$DATA(^XUSEC("PSORPH",DUZ))
- Begin DoDot:1
- +6 SET PSORX("DFLG")=1
- KILL RXRECLOC,DIR
- SET DIR(0)="E"
- SET DIR("?")="Press Return to continue"
- SET DIR("A")="Press Return to continue"
- +7 DO ^DIR
- KILL DIR
- End DoDot:1
- QUIT
- +8 IF $PIECE(PSOSD(STA,DNM),"^",2)=16
- IF $GET(DUP)
- Begin DoDot:1
- +9 WRITE !!,"Prescription "_$PIECE($GET(^PSRX(+$GET(RXRECLOC),0)),"^")_" is on Provider Hold, it cannot be discontinued.",!
- +10 KILL DUP,DIR,RXRECLOC
- SET PSORX("DFLG")=1
- SET DIR(0)="E"
- SET DIR("?")="Press Return to continue"
- SET DIR("A")="Press Return to continue"
- DO ^DIR
- KILL DIR
- End DoDot:1
- QUIT
- +11 DO PSOL^PSSLOCK(RXRECLOC)
- IF '$GET(PSOMSG)
- Begin DoDot:1
- +12 IF $PIECE($GET(PSOMSG),"^",2)'=""
- WRITE !!,$PIECE(PSOMSG,"^",2),!
- QUIT
- +13 WRITE !!,"Another person is editing Rx "_$PIECE($GET(^PSRX(RXRECLOC,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
- +14 IF $DATA(PSODGCK)
- KILL RXRECLOC,DUP,CLS,PSONOOR
- QUIT
- +15 KILL PSOMSG
- SET DIR("A")=$SELECT($PIECE(PSOSD(STA,DNM),"^",2)=12:"Reinstate",1:"Discontinue")_" RX # "_$PIECE(^PSRX(+PSOSD(STA,DNM),0),"^")_" "_$PIECE(DNM,"^")_" Y/N"
- SET DIR(0)="Y"
- +16 SET DIR("?")="Enter Y to "_$SELECT($PIECE(PSOSD(STA,DNM),"^",2)=12:"reinstate",1:"discontinue")_" this RX."
- +17 DO ^DIR
- KILL DIR
- SET DA=RXREC
- SET ACT=$SELECT($DATA(SPCANC):"Reinstated during Rx cancel.",1:$SELECT($PIECE(PSOSD(STA,DNM),"^",2)=12:"Reinstated",1:"Discontinued")_" while "_$SELECT('$GET(PSONV):"entering",1:"verifying")_" new RX")
- +18 DO CMOP^PSOUTL
- IF $GET(CMOP("S"))="L"
- WRITE !,"A CMOP Rx cannot be discontinued during transmission!",!
- SET Y=0
- KILL CMOP
- +19 IF 'Y
- WRITE !,$CHAR(7)," -Prescription was not "_$SELECT($PIECE(PSOSD(STA,DNM),"^",2)=12:"reinstated",1:"discontinued")_"..."
- Begin DoDot:1
- +20 if '$DATA(PSOCLC)
- SET PSOCLC=DUZ
- SET MSG=ACT
- SET REA=$SELECT($PIECE(PSOSD(STA,DNM),"^",2)=12:"R",1:"C")
- if $GET(DUP)
- SET PSORX("DFLG")=1
- KILL DUP
- DO ULRX
- KILL RXRECLOC
- +21 KILL ^TMP("PSORXDC",$JOB,RXREC,0)
- End DoDot:1
- QUIT
- +22 IF $PIECE(PSOSD(STA,DNM),"^",2)=16
- IF $GET(CLS)
- WRITE !!,"Prescription "_$PIECE($GET(^PSRX(+$GET(RXRECLOC),0)),"^")_" is on Provider Hold, it cannot be discontinued.",!
- DO ULRX
- KILL CLS,DUP,RXRECLOC
- SET PSORX("DFLG")=1
- HANG 2
- QUIT
- +23 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($PIECE(PSOSD(STA,DNM),"^",2)=12:"R",1:"C")
- +24 WRITE !!
- KILL ^UTILITY($JOB,"W")
- SET DIWL=1
- SET DIWR=75
- SET DIWF=""
- +25 SET X="Rx #"_$PIECE(^PSRX(+PSOSD(STA,DNM),0),"^")_" "_DNM_" will be discontinued after"_$SELECT('$GET(PSOTECCK):" the acceptance of the new order.",1:" reinstating the order.")
- DO ^DIWP
- +26 NEW ZX
- FOR ZX=0:0
- SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
- if 'ZX
- QUIT
- WRITE !,^UTILITY($JOB,"W",1,ZX,0)
- +27 KILL ^UTILITY($JOB,"W"),X,DIWL,DIWR,DIWF
- WRITE !
- +28 SET ^TMP("PSORXDC",$JOB,RXREC,0)="52^"_DA_"^"_MSG_"^"_REA_"^"_ACT_"^"_STA_"^"_DNM
- SET PSONOOR="D"
- SET ^TMP("PSORXDD",$JOB)=DNM
- HANG 2
- +29 KILL RXRECLOC,DUP,CLS,PSONOOR
- +30 QUIT
- FDB ;build drug check input
- +1 NEW ID,ORTYP,PSOI,ORN
- SET DFN=PSODFN
- SET CT=0
- +2 SET ID=+$$GETVUID^XTID(50.68,,+$PIECE(PSODRUG("NDF"),"A",2)_",")
- +3 SET P1=$PIECE(PSODRUG("NDF"),"A")
- SET P2=$PIECE(PSODRUG("NDF"),"A",2)
- SET X=$$PROD0^PSNAPIS(P1,P2)
- SET SEQN=+$PIECE(X,"^",7)
- +4 IF 'SEQN
- KILL ^TMP($JOB,LIST,"OUT","EXCEPTIONS")
- +5 SET ^TMP($JOB,LIST,"IN","PROSPECTIVE","Z;1;PROSPECTIVE;1")=SEQN_"^"_ID_"^"_PSODRUG("IEN")_"^"_$PIECE(^PSDRUG(PSODRUG("IEN"),0),"^")
- +6 IF $GET(PSODGCKX)
- KILL ^TMP($JOB,LIST,"IN","PROSPECTIVE","Z;1;PROSPECTIVE;1")
- +7 SET ^TMP($JOB,LIST,"IN","IEN")=PSODFN
- SET ^TMP($JOB,LIST,"IN","DRUGDRUG")=""
- SET ^TMP($JOB,LIST,"IN","THERAPY")=""
- +8 KILL ID,P1,P2
- NEW ODRG,TU
- SET (STA,DNM)=""
- IF '$GET(PSOCOPY)
- IF '$GET(SEQN)
- IF '$GET(PSODGCK)
- KILL SEQN
- QUIT
- +9 ;build profile drug order checks
- +10 FOR
- SET STA=$ORDER(PSOSD(STA))
- if STA=""
- QUIT
- FOR
- SET DNM=$ORDER(PSOSD(STA,DNM))
- if DNM=""
- QUIT
- Begin DoDot:1
- +11 if $PIECE(PSOSD(STA,DNM),"^")=$GET(PSORENW("OIRXN"))&('$GET(PSOCOPY))
- QUIT
- +12 SET CT=CT+1
- +13 IF STA="PENDING"
- NEW DDRG
- Begin DoDot:2
- +14 if $GET(^TMP("PSORXDC",$JOB,$PIECE(PSOSD(STA,DNM),"^",10),0))]""
- QUIT
- +15 if $GET(PSODRUG("IEN"))=$PIECE(^PS(52.41,$PIECE(PSOSD(STA,DNM),"^",10),0),"^",9)
- QUIT
- +16 if $PIECE(^PS(52.41,$PIECE(PSOSD(STA,DNM),"^",10),0),"^",3)="RF"
- QUIT
- +17 if $GET(^TMP("PSORXPO",$JOB,$PIECE(PSOSD(STA,DNM),"^",10),0))
- QUIT
- +18 SET RXREC=$PIECE(PSOSD(STA,DNM),"^",10)
- SET ORN=$PIECE(^PS(52.41,RXREC,0),"^")
- SET ODRG=$PIECE(^(0),"^",9)
- SET ORTYP="P"
- +19 IF ODRG
- Begin DoDot:3
- +20 IF $PIECE($GET(^PSDRUG(ODRG,0)),"^",3)["S"!($EXTRACT($PIECE($GET(^PSDRUG(ODRG,0)),"^",2),1,2)="XA")
- QUIT
- +21 SET PDNM=$PIECE(^PSDRUG(ODRG,0),"^")
- DO ID
- End DoDot:3
- KILL ODRG
- QUIT
- +22 IF '$TEST
- NEW PSOI,DDRG,ODRG,SEQN,DDRG
- SET PSOI=$PIECE(^PS(52.41,RXREC,0),"^",8)
- Begin DoDot:3
- +23 SET PDNM=$PIECE(^PS(50.7,PSOI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^")
- +24 SET DDRG=$$DRG^PSSDSAPM(PSOI,"O")
- IF '$PIECE(DDRG,";")
- if '$$NVATST(PSOI,"O")
- DO OIX
- QUIT
- +25 IF $PIECE($GET(^PSDRUG($PIECE(DDRG,";"),0)),"^",3)["S"!($EXTRACT($PIECE($GET(^PSDRUG($PIECE(DDRG,";"),0)),"^",2),1,2)="XA")
- QUIT
- +26 SET ODRG=$PIECE(DDRG,";")
- SET SEQN=+$PIECE(DDRG,";",3)
- KILL PSOI
- +27 NEW ID
- SET ID=+$$GETVUID^XTID(50.68,,+$PIECE($GET(^PSDRUG(ODRG,"ND")),"^",3)_",")
- +28 DO ID1
- End DoDot:3
- End DoDot:2
- +29 IF STA="ZNONVA"
- Begin DoDot:2
- +30 if $GET(^TMP($JOB,"PSONVADD",$PIECE(PSOSD(STA,DNM),"^",10),0))]""
- QUIT
- +31 SET RXREC=$PIECE(PSOSD(STA,DNM),"^",10)
- SET ODRG=$PIECE(^PS(55,PSODFN,"NVA",RXREC,0),"^",2)
- SET ORN=$PIECE(^(0),"^",8)
- SET ORTYP="N"
- +32 IF ODRG
- Begin DoDot:3
- +33 IF $PIECE($GET(^PSDRUG(ODRG,0)),"^",3)["S"!($EXTRACT($PIECE($GET(^PSDRUG(ODRG,0)),"^",2),1,2)="XA")
- QUIT
- +34 ;CT=2 prevents overwrite of CK action drug prompt reply
- SET PDNM=$PIECE(^PSDRUG(ODRG,0),"^")
- if CT=1&($GET(PSODGCK))&('$GET(PSODGCKX))
- SET CT=2
- DO ID
- End DoDot:3
- KILL ODRG
- QUIT
- +35 IF '$TEST
- NEW PSOI,DDRG,ODRG,SEQN,DDRG
- SET PSOI=$PIECE(^PS(55,PSODFN,"NVA",RXREC,0),"^")
- Begin DoDot:3
- +36 SET PDNM=$PIECE(^PS(50.7,PSOI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^")
- +37 SET DDRG=$$DRG^PSSDSAPM(PSOI,"X")
- IF '$PIECE(DDRG,";")
- if '$$NVATST(PSOI,"X")
- DO OIX
- QUIT
- +38 IF $PIECE($GET(^PSDRUG($PIECE(DDRG,";"),0)),"^",3)["S"!($EXTRACT($PIECE($GET(^PSDRUG($PIECE(DDRG,";"),0)),"^",2),1,2)="XA")
- QUIT
- +39 SET ODRG=$PIECE(DDRG,";")
- SET SEQN=+$PIECE(DDRG,";",3)
- KILL PSOI
- +40 NEW ID
- SET ID=+$$GETVUID^XTID(50.68,,+$PIECE($GET(^PSDRUG(ODRG,"ND")),"^",3)_",")
- +41 ;prevents overwrite of CK action drug prompt reply
- IF CT=1
- IF $GET(PSODGCK)
- IF '$GET(PSODGCKX)
- SET CT=2
- +42 DO ID1
- End DoDot:3
- End DoDot:2
- QUIT
- +43 IF $PIECE($GET(^PSRX(+PSOSD(STA,DNM),0)),"^",6)
- Begin DoDot:2
- +44 if $GET(^TMP("PSORXDC",$JOB,$PIECE(PSOSD(STA,DNM),"^"),0))]""
- QUIT
- +45 if $GET(^TMP("PSORXBO",$JOB,$PIECE(PSOSD(STA,DNM),"^"),0))
- QUIT
- +46 if $GET(^TMP("PSORXDD",$JOB,$PIECE(PSOSD(STA,DNM),"^"),0))
- QUIT
- +47 ;I $P(PSOSD(STA,DNM),"^",2)>5,$P(PSOSD(STA,DNM),"^",2)'=16 Q
- +48 SET RXREC=+PSOSD(STA,DNM)
- SET ODRG=$PIECE(^PSRX(RXREC,0),"^",6)
- SET ORN=$PIECE($GET(^("OR1")),"^",2)
- SET ORTYP="O"
- +49 IF ODRG
- Begin DoDot:3
- +50 IF $PIECE($GET(^PSDRUG(ODRG,0)),"^",3)["S"!($EXTRACT($PIECE($GET(^PSDRUG(ODRG,0)),"^",2),1,2)="XA")
- QUIT
- +51 IF STA="DISCONTINUED"
- if $$DUPTHER(RXREC)
- QUIT
- +52 SET PDNM=$PIECE(^PSDRUG(ODRG,0),"^")
- DO ID
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +53 DO IMO^PSODDPR7(PSODFN)
- +54 KILL RXREC,ID,STA,DNM,PSOI,ORN,ODRG,ORTYP,CT,PDNM,TU,DDRG
- +55 QUIT
- +56 ;
- ID NEW ID,P1,P2,PSODGCKP
- SET ID=+$$GETVUID^XTID(50.68,,+$PIECE($GET(^PSDRUG(ODRG,"ND")),"^",3)_",")
- +1 SET P1=$PIECE($GET(^PSDRUG(ODRG,"ND")),"^")
- SET P2=$PIECE($GET(^("ND")),"^",3)
- SET X=$$PROD0^PSNAPIS(P1,P2)
- SET SEQN=$PIECE(X,"^",7)
- ID1 SET PSODGCKP=$SELECT($GET(PSODGCK):"PROSPECTIVE",1:"PROFILE")
- +1 SET ^TMP($JOB,LIST,"IN",PSODGCKP,$SELECT($DATA(PSODGCK):"Z",1:ORTYP)_";"_RXREC_";"_PSODGCKP_";"_CT)=SEQN_"^"_ID_"^"_ODRG_"^"_PDNM_"^"_ORN_"^O"
- KILL ID
- +2 QUIT
- DUPTHER(RXREC) ;screen out discontinued/duplicate therapy Rx's greater than business rule calculation (cancel date + days supply +7 days)
- +1 ;Note: If the dup allowance is 1 you have to have at least 3 eligible drug orders (or 2 matches) to produce the dupl. therapy warning
- +2 ;Business rule for expired orders is (expiration date+120 days) which is the length of time expired order currently stay on med profile. No changes for this.
- +3 NEW X,Y,X1,X2
- SET X1=$PIECE($GET(^PSRX(RXREC,3)),"^",5)
- SET X2=(+$PIECE(^PSRX(RXREC,0),"^",8)+7)
- DO C^%DTC
- IF DT>X
- QUIT 1
- +4 QUIT 0
- OIX SET ^TMP($JOB,LIST,"IN","EXCEPTIONS","OI",PDNM)=1_"^"_ORTYP_";"_RXREC_";PROFILE;"_CT
- +1 QUIT
- ULRX ;
- +1 IF '$GET(RXRECLOC)
- QUIT
- +2 DO PSOUL^PSSLOCK(RXRECLOC)
- +3 QUIT
- +4 ;
- PRSTAT(DA) ;Displays the prescription's status
- +1 NEW PSOTRANS,PSOREL,PSOCMOP,RXPSTA,PSOX,RFLZRO,PSOLRD,PSORTS,CMOP,PSORFL,PSOMW
- +2 ;PSO*7*411 to comment
- if (($Y+5)>IOSL)
- DO HD^PSODDPR2()
- if $GET(PSODLQT)
- QUIT
- +3 SET RXPSTA="Processing Status: "
- SET PSOLRD=$PIECE($GET(^PSRX(RXREC,2)),"^",13)
- +4 ;
- +5 DO ^PSOCMOPA
- IF $GET(PSOCMOP)]""
- Begin DoDot:1
- +6 SET PSOTRANS=$EXTRACT($PIECE(PSOCMOP,"^",2),4,5)_"/"_$EXTRACT($PIECE(PSOCMOP,"^",2),6,7)_"/"_$EXTRACT($PIECE(PSOCMOP,"^",2),2,3)
- +7 SET PSOREL=$SELECT(CMOP("L")=0:$PIECE($GET(^PSRX(DA,2)),"^",13),1:$PIECE(^PSRX(DA,1,CMOP("L"),0),"^",18))
- +8 SET PSOREL=$EXTRACT(PSOREL,4,5)_"/"_$EXTRACT(PSOREL,6,7)_"/"_$EXTRACT(PSOREL,2,3)_"@"_$EXTRACT($PIECE(PSOREL,".",2),1,4)
- +9 IF '$DATA(IOINORM)!('$DATA(IOINHI))
- SET X="IORVOFF;IORVON;IOINHI;IOINORM"
- DO ENDR^%ZISS
- +10 IF $PIECE($GET(^PSRX(RXREC,"STA")),"^")=0
- if $$TRANCMOP^PSOUTL(RXREC)
- WRITE ?5,IORVON_IOINHI
- +11 if $GET(PSODUPF)
- SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
- +12 if '$GET(PSODUPF)
- WRITE !,$JUSTIFY(RXPSTA,24)_$SELECT($PIECE(PSOCMOP,"^")=0!($PIECE(PSOCMOP,"^")=2):"Transmitted to CMOP on "_PSOTRANS,$PIECE(PSOCMOP,"^")=1:"Released by CMOP on "_PSOREL,$PIECE(PSOCMOP,"^")=3&(PSOLRD):"Dispensed locally NOT by CMOP",
- 1:"Not Dispensed")
- +13 if '$GET(PSODUPF)
- WRITE IOINORM_IORVOFF
- End DoDot:1
- KILL CMOP,PSOTRANS,PSOREL
- +14 if (($Y+5)>IOSL)
- DO HD^PSODDPR2()
- if $GET(PSODLQT)
- QUIT
- +15 IF $GET(PSOCMOP)']""
- Begin DoDot:1
- +16 SET PSORFL=0
- +17 FOR PSOX=0:0
- SET PSOX=$ORDER(^PSRX(RXREC,1,PSOX))
- if 'PSOX
- QUIT
- Begin DoDot:2
- +18 ;PSO*7*768
- SET PSORFL=PSOX
- +19 SET RFLZRO=$GET(^PSRX(RXREC,1,PSOX,0))
- +20 if $PIECE(RFLZRO,"^",18)'=""
- SET PSOLRD=$PIECE(RFLZRO,"^",18)
- IF $PIECE(RFLZRO,"^",16)
- SET PSOLRD=PSOLRD_"^R"
- SET PSORTS=$PIECE(RFLZRO,"^",16)
- End DoDot:2
- +21 IF '$ORDER(^PSRX(RXREC,1,0))
- IF $PIECE(^PSRX(RXREC,2),"^",15)
- SET PSOLRD=PSOLRD_"^R"
- SET PSORTS=$PIECE(^PSRX(RXREC,2),"^",15)
- +22 if $GET(PSODUPF)
- SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
- if '$GET(PSODUPF)
- WRITE !,$JUSTIFY(RXPSTA,24)
- +23 IF +$GET(PSORTS)
- if $GET(PSODUPF)
- SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
- if '$GET(PSODUPF)
- WRITE "Returned to stock on "_$$FMTE^XLFDT(PSORTS,2)
- QUIT
- +24 if $GET(PSODUPF)
- SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
- +25 ;PSO*7*768
- +26 SET PSOMW=""
- +27 IF PSORFL
- SET PSOMW=$SELECT($PIECE(^PSRX(RXREC,1,PSORFL,0),"^",2)="W":" (Window)",1:" (Mail)")
- +28 IF PSOMW=""
- SET PSOMW=$SELECT($PIECE(^PSRX(RXREC,0),"^",11)="W":" (Window)",1:" (Mail)")
- +29 if '$GET(PSODUPF)
- WRITE $SELECT(PSOLRD="":"Not released locally",1:"Released locally on "_$$FMTE^XLFDT($PIECE(PSOLRD,"^"),2)_" "_$PIECE(PSOLRD,"^",2))_PSOMW
- End DoDot:1
- +30 QUIT
- +31 ;
- DATACK ;check FDB returned data to determine whether to continue processing.
- +1 SET DIR(0)="E"
- SET DIR("A",1)="No Enhanced Order Checks can be performed."
- +2 SET DIR("A",2)=" Reason(s): "_$PIECE($GET(^TMP($JOB,LIST,"OUT",0)),"^",2)
- +3 SET DIR("A")="Press Return to continue..."
- SET DIR("?")="Press Return to continue"
- +4 ;I $P(^TMP($J,LIST,"OUT",0),"^")=1
- WRITE !
- DO ^DIR
- KILL DIRUT,DUOUT,DIR,X,Y
- WRITE @IOF
- +5 QUIT
- +6 ;
- NVATST(PSONVTOI,PSONVTAP) ; Look for any active Non-VA Dispense Drugs not marked as a supply item
- +1 NEW PSONVT1,PSONVTFL,PSONVTIN
- +2 SET PSONVTFL=1
- +3 FOR PSONVT1=0:0
- SET PSONVT1=$ORDER(^PSDRUG("ASP",PSONVTOI,PSONVT1))
- if 'PSONVT1!('PSONVTFL)
- QUIT
- Begin DoDot:1
- +4 IF $PIECE($GET(^PSDRUG(PSONVT1,2)),"^",3)'[PSONVTAP
- QUIT
- +5 SET PSONVTIN=$PIECE($GET(^PSDRUG(PSONVT1,"I")),"^")
- IF PSONVTIN
- IF PSONVTIN<DT
- QUIT
- +6 SET PSONVTFL=$$SUP^PSSDSAPI(PSONVT1)
- End DoDot:1
- +7 QUIT PSONVTFL