source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMAUEX.m@ 841

Last change on this file since 841 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version

File size: 4.3 KB
Line 
1PSOMAUEX ;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
40EN 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
45EN1 ;
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
50EN2 ;
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
73EN3 ;
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
78ENX I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET
79 Q
80NSET ;
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 TracBrowser for help on using the repository browser.