- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMAUEX.m
r613 r623 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 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
Note:
See TracChangeset
for help on using the changeset viewer.
