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