| [623] | 1 | PSOMAUEX ;BIR/SAB-Auto expire of prescriptions ;10/10/96
|
|---|
| 2 | ;;7.0;OUTPATIENT PHARMACY;**40,73,139,148**;DEC 1997
|
|---|
| 3 | ;External reference to ^PS(59.7 is supported by DBIA 694
|
|---|
| 4 | ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
|
|---|
| 5 | ;
|
|---|
| 6 | I '$G(DT) S DT=$$DT^XLFDT
|
|---|
| 7 | W @IOF,!!?10," ******* Auto Expire of Prescriptions *******"
|
|---|
| 8 | W !!,"You need to run this job only if expired prescriptions are showing up as active"
|
|---|
| 9 | W !,"orders on the Orders tab in CPRS. This could be due to the following:"
|
|---|
| 10 | W !,"1. The Expire Prescriptions [PSO EXPIRE PRESCRIPTIONS] option was not"
|
|---|
| 11 | W !," queued as a daily task. ***** AND *****"
|
|---|
| 12 | W !,"2. Those patient's prescription(s) were never being accessed/viewed in"
|
|---|
| 13 | W !," Patient Prescription Processing [PSO LM BACKDOOR ORDERS] option.",!
|
|---|
| 14 | W !,"*******************************************************************************"
|
|---|
| 15 | W !,"* For sites that have not queued the Expire Prescriptions job on their *"
|
|---|
| 16 | W !,"* daily task schedule, you should do so by selecting the Queue Background *"
|
|---|
| 17 | W !,"* Jobs [PSO AUTOQUEUE JOBS] option from the Maintenance (Outpatient Pharmacy) *"
|
|---|
| 18 | W !,"* [PSO MAINTENANCE] option and in the Edit Option Schedule template make an *"
|
|---|
| 19 | W !,"* entry for Expire Prescriptions [PSO EXPIRE PRESCRIPTIONS] option and *"
|
|---|
| 20 | W !,"* schedule it to run daily. *"
|
|---|
| 21 | W !,"*******************************************************************************"
|
|---|
| 22 | W !!
|
|---|
| 23 | S ZZIDT=$S($P($G(^PS(59.7,1,49.99)),"^",7):$P(^PS(59.7,1,49.99),"^",7),1:$P($G(^PS(59.7,1,49.99)),"^",4))
|
|---|
| 24 | I 'ZZIDT D Q ; V7.0 inst. dt not found, quit this job
|
|---|
| 25 | .W !!!,"***** Outpatient installation date was not found, *****"
|
|---|
| 26 | .W !,"***** therefore this job cannot be run!!!!! *****",!!
|
|---|
| 27 | ;
|
|---|
| 28 | ; - Ask for START DATE
|
|---|
| 29 | K %DT S %DT(0)=-DT,%DT="AEP",%DT("A")="Start Date: "
|
|---|
| 30 | S %DT("B")=$$FMTE^XLFDT($$FMADD^XLFDT(ZZIDT\1-121))
|
|---|
| 31 | W ! D ^%DT I Y<0!($D(DTOUT)) Q
|
|---|
| 32 | S ZZIDT=Y
|
|---|
| 33 | ;
|
|---|
| 34 | K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Select the Date/Time to queue this job: "
|
|---|
| 35 | W ! D ^%DT K %DT I $D(DTOUT)!(Y<0) W !!!?10,"Job not queued!" Q
|
|---|
| 36 | S ZTDTH=$G(Y),ZTSAVE("ZZIDT")="",ZTIO="",ZTRTN="EN^PSOMAUEX",ZTDESC="Auto expire of Rxs "
|
|---|
| 37 | D ^%ZTLOAD
|
|---|
| 38 | W:$D(ZTSK) !!,"Task Queued !",!
|
|---|
| 39 | Q
|
|---|
| 40 | EN S X1=ZZIDT,X2=-121 D C^%DTC S ZZDT=X ;setting the start date to 120 days before the install date
|
|---|
| 41 | S X1=DT,X2=-1 D C^%DTC S CDT=X ; setting the end date to todate-1
|
|---|
| 42 | F S ZZDT=$O(^PSRX("AG",ZZDT)) Q:'ZZDT!(ZZDT>CDT) D EN1
|
|---|
| 43 | K PSOEXRX,PSOEXSTA,ZZIDT,ZZDT,CDT,ORN,PIFN,PSUSD,PRFDT,PDA,PSDTEST S:$D(ZTQUEUED) ZTREQ="@"
|
|---|
| 44 | Q
|
|---|
| 45 | EN1 ;
|
|---|
| 46 | F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX D
|
|---|
| 47 | .Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT
|
|---|
| 48 | .I $D(^PSRX(PSOEXRX,0)) D EN2
|
|---|
| 49 | Q
|
|---|
| 50 | EN2 ;
|
|---|
| 51 | S DA=$O(^PS(52.5,"B",PSOEXRX,0))
|
|---|
| 52 | I DA,$P($G(^PS(52.5,DA,0)),"^",2),$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK
|
|---|
| 53 | I $D(^PS(52.4,PSOEXRX,0)) S DIK="^PS(52.4,",DA=PSOEXRX D ^DIK K DIK
|
|---|
| 54 | I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")=""
|
|---|
| 55 | S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^")
|
|---|
| 56 | I PSOEXSTA=11 D
|
|---|
| 57 | .S $P(^PSRX(PSOEXRX,0),"^",19)=1
|
|---|
| 58 | .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2)
|
|---|
| 59 | .I ORN,+$$STATUS^ORQOR2(ORN)=6 D
|
|---|
| 60 | ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
|
|---|
| 61 | I (PSOEXSTA="")!(PSOEXSTA>9) Q
|
|---|
| 62 | ;
|
|---|
| 63 | ;get only those Rxs whoes status lies within 0 & 9
|
|---|
| 64 | I PSOEXSTA?1N,+$P($G(^PSRX(PSOEXRX,2)),"^",6),+$P($G(^(2)),"^",6)<DT D
|
|---|
| 65 | .S $P(^PSRX(PSOEXRX,"STA"),"^")=11
|
|---|
| 66 | .I $P($G(^PSRX(PSOEXRX,"OR1")),"^",2) D
|
|---|
| 67 | ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription past expiration date")
|
|---|
| 68 | .S (PIFN,PSUSD,PRFDT)=0
|
|---|
| 69 | .F S PIFN=$O(^PSRX(PSOEXRX,1,PIFN)) Q:'PIFN S PSUSD=PIFN,PRFDT=+$P($G(^PSRX(PSOEXRX,1,PIFN,0)),"^")
|
|---|
| 70 | .D REVERSE^PSOBPSU1(PSOEXRX,+PSUSD,"DE",5,"RX EXPIRED")
|
|---|
| 71 | .I $G(PSUSD),'$P($G(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18) D EN3
|
|---|
| 72 | Q
|
|---|
| 73 | EN3 ;
|
|---|
| 74 | S (PSDTEST,PDA)=0 F S PDA=$O(^PSRX(PSOEXRX,"L",PDA)) Q:'PDA S:$P($G(^PSRX(PSOEXRX,"L",PDA,0)),"^",2)=PSUSD PSDTEST=1
|
|---|
| 75 | Q:PSDTEST
|
|---|
| 76 | S DA=PSOEXRX K CMOP D ^PSOCMOPA
|
|---|
| 77 | I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))="L" S PSDTEST=1
|
|---|
| 78 | ENX I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET
|
|---|
| 79 | Q
|
|---|
| 80 | NSET ;
|
|---|
| 81 | N PSONM,PSONMX
|
|---|
| 82 | S PSONM="" F PSONMX=0:0 S PSONMX=$O(^PSRX(PSOEXRX,1,PSONMX)) Q:'PSONMX S PSONM=PSONMX
|
|---|
| 83 | S ^PSRX(PSOEXRX,1,0)="^52.1DA^"_$G(PSONM)_"^"_$G(PSONM)
|
|---|
| 84 | Q
|
|---|
