PSOMAUEX ;BIR/SAB-Auto expire of prescriptions ; 10/10/07 11:17am
;;7.0;OUTPATIENT PHARMACY;**40,73,139,148,257**;DEC 1997;Build 19
;;
;External reference to STATUS^ORQOR2 is supported by DBIA 3458
;External reference to ^PS(59.7 is supported by DBIA 694
;External reference to LOCK1^ORX2 and UNLK1^ORX2 are supported by DBIA 867
;
I '$G(DT) S DT=$$DT^XLFDT
W @IOF,!!?10," ******* Auto Expire of Prescriptions *******"
W !!,"You need to run this job only if expired prescriptions are showing up as active"
W !,"orders on the Orders tab in CPRS. This could be due to the following:"
W !,"1. The Expire Prescriptions [PSO EXPIRE PRESCRIPTIONS] option was not"
W !," queued as a daily task. ***** AND *****"
W !,"2. Those patient's prescription(s) were never being accessed/viewed in"
W !," Patient Prescription Processing [PSO LM BACKDOOR ORDERS] option.",!
W !,"*******************************************************************************"
W !,"* For sites that have not queued the Expire Prescriptions job on their *"
W !,"* daily task schedule, you should do so by selecting the Queue Background *"
W !,"* Jobs [PSO AUTOQUEUE JOBS] option from the Maintenance (Outpatient Pharmacy) *"
W !,"* [PSO MAINTENANCE] option and in the Edit Option Schedule template make an *"
W !,"* entry for Expire Prescriptions [PSO EXPIRE PRESCRIPTIONS] option and *"
W !,"* schedule it to run daily. *"
W !,"*******************************************************************************"
W !!
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))
I 'ZZDT D Q ; V7.0 inst. dt not found, quit this job
.W !!!,"***** Outpatient installation date was not found, *****"
.W !,"***** therefore this job cannot be run!!!!! *****",!!
;
; - Ask for START DATE
K %DT S %DT(0)=-DT,%DT="AEP",%DT("A")="Start Date: "
S %DT("B")=$$FMTE^XLFDT($$FMADD^XLFDT(ZZDT\1,-121))
W ! D ^%DT I Y<0!($D(DTOUT)) Q
S ZZDT=Y
;
K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Select the Date/Time to queue this job: "
W ! D ^%DT K %DT I $D(DTOUT)!(Y<0) W !!!?10,"Job not queued!" Q
S ZTDTH=$G(Y),ZTSAVE("ZZDT")="",ZTIO="",ZTRTN="EN^PSOMAUEX",ZTDESC="Auto expire of Rxs "
D ^%ZTLOAD
W:$D(ZTSK) !!,"Task Queued !",!
Q
EN ;
N PSOSVDT
S PSOSVDT=""
S X1=DT,X2=-1 D C^%DTC S CDT=X ; setting the end date to to today-1
F S ZZDT=$O(^PSRX("AG",ZZDT)) Q:'ZZDT!(ZZDT>CDT) D EN1 S PSOSVDT=ZZDT
I PSOSVDT>($P(^PS(59.7,1,49.99),"^",8)) D
.S DIE=59.7,DA=1,DR="49.95///"_PSOSVDT D ^DIE K DIE,DA,DR
K PSOEXRX,PSOEXSTA,ZZDT,CDT,ORN,PIFN,PSUSD,PRFDT,PDA,PSDTEST S:$D(ZTQUEUED) ZTREQ="@"
Q
EN1 ;
F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX D
.Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT
.I $D(^PSRX(PSOEXRX,0)) D EN2
Q
EN2 ;
N CPRSDC,CPRSSTA
S CPRSDC=",1,7,12,13,"
S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2),CPRSSTA=""
I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN)
S DA=PSOEXRX K CMOP D ^PSOCMOPA
S DA=$O(^PS(52.5,"B",PSOEXRX,0))
I DA,$P($G(^PS(52.5,DA,0)),"^",2),$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK
I $D(^PS(52.4,PSOEXRX,0)) S DIK="^PS(52.4,",DA=PSOEXRX D ^DIK K DIK
I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")=""
S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^")
;
I PSOEXSTA=11 S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) I ORN I CPRSDC'[(","_CPRSSTA_",") D
.S $P(^PSRX(PSOEXRX,0),"^",19)=1
.D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
;
I PSOEXSTA=13 D Q
.I 'ORN D EN^PSOHDR("PRES",PSOEXRX)
;
I PSOEXSTA>9&(PSOEXSTA'=16) Q
;
I +$P($G(^PSRX(PSOEXRX,2)),"^",6),+$P($G(^(2)),"^",6)<DT D
.S $P(^PSRX(PSOEXRX,"STA"),"^")=11
.S (PIFN,PSUSD,PRFDT)=0
.F S PIFN=$O(^PSRX(PSOEXRX,1,PIFN)) Q:'PIFN S PSUSD=PIFN,PRFDT=+$P($G(^PSRX(PSOEXRX,1,PIFN,0)),"^")
.D REVERSE^PSOBPSU1(PSOEXRX,+PSUSD,"DE",5,"RX EXPIRED")
.I $G(PSUSD),'$P($G(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18) D EN3
.S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) I 'ORN D EN^PSOHDR("PRES",PSOEXRX) Q
.;If CPRS side already DC'd or expired, just send the expiration to the HDR
.I CPRSDC[(","_CPRSSTA_",") D EN^PSOHDR("PRES",PSOEXRX) Q
.S $P(^PSRX(PSOEXRX,0),"^",19)=1
.D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription past expiration date")
Q
EN3 ;
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
Q:PSDTEST
I $G(CMOP(CMOP("L")))="",".L.X."[("."_$G(CMOP("S"))_".") S PSDTEST=1
N PSOORL
S PSOORL=$$LOCK1^ORX2(ORN) S:'PSOORL PSDTEST=1 I PSOORL D UNLK1^ORX2(ORN)
N PDAQ,PDA0
S PDAQ=0
F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,4,PDA)) Q:'PDA D
.S PDA0=$G(^PSRX(PSOEXRX,4,PDA,0)) Q:PDA0=""
.I $P(PDA0,"^",3)=PSUSD S PSDTEST=1
ENX I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET
Q
NSET ;
N PSONM,PSONMX
S PSONM="" F PSONMX=0:0 S PSONMX=$O(^PSRX(PSOEXRX,1,PSONMX)) Q:'PSONMX S PSONM=PSONMX
S ^PSRX(PSOEXRX,1,0)="^52.1DA^"_$G(PSONM)_"^"_$G(PSONM)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOMAUEX 5197 printed Nov 22, 2024@17:40:59 Page 2
PSOMAUEX ;BIR/SAB-Auto expire of prescriptions ; 10/10/07 11:17am
+1 ;;7.0;OUTPATIENT PHARMACY;**40,73,139,148,257**;DEC 1997;Build 19
+2 ;;
+3 ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
+4 ;External reference to ^PS(59.7 is supported by DBIA 694
+5 ;External reference to LOCK1^ORX2 and UNLK1^ORX2 are supported by DBIA 867
+6 ;
+7 IF '$GET(DT)
SET DT=$$DT^XLFDT
+8 WRITE @IOF,!!?10," ******* Auto Expire of Prescriptions *******"
+9 WRITE !!,"You need to run this job only if expired prescriptions are showing up as active"
+10 WRITE !,"orders on the Orders tab in CPRS. This could be due to the following:"
+11 WRITE !,"1. The Expire Prescriptions [PSO EXPIRE PRESCRIPTIONS] option was not"
+12 WRITE !," queued as a daily task. ***** AND *****"
+13 WRITE !,"2. Those patient's prescription(s) were never being accessed/viewed in"
+14 WRITE !," Patient Prescription Processing [PSO LM BACKDOOR ORDERS] option.",!
+15 WRITE !,"*******************************************************************************"
+16 WRITE !,"* For sites that have not queued the Expire Prescriptions job on their *"
+17 WRITE !,"* daily task schedule, you should do so by selecting the Queue Background *"
+18 WRITE !,"* Jobs [PSO AUTOQUEUE JOBS] option from the Maintenance (Outpatient Pharmacy) *"
+19 WRITE !,"* [PSO MAINTENANCE] option and in the Edit Option Schedule template make an *"
+20 WRITE !,"* entry for Expire Prescriptions [PSO EXPIRE PRESCRIPTIONS] option and *"
+21 WRITE !,"* schedule it to run daily. *"
+22 WRITE !,"*******************************************************************************"
+23 WRITE !!
+24 SET ZZDT=$SELECT($PIECE($GET(^PS(59.7,1,49.99)),"^",7):$PIECE(^PS(59.7,1,49.99),"^",7),1:$PIECE($GET(^PS(59.7,1,49.99)),"^",4))
+25 ; V7.0 inst. dt not found, quit this job
IF 'ZZDT
Begin DoDot:1
+26 WRITE !!!,"***** Outpatient installation date was not found, *****"
+27 WRITE !,"***** therefore this job cannot be run!!!!! *****",!!
End DoDot:1
QUIT
+28 ;
+29 ; - Ask for START DATE
+30 KILL %DT
SET %DT(0)=-DT
SET %DT="AEP"
SET %DT("A")="Start Date: "
+31 SET %DT("B")=$$FMTE^XLFDT($$FMADD^XLFDT(ZZDT\1,-121))
+32 WRITE !
DO ^%DT
IF Y<0!($DATA(DTOUT))
QUIT
+33 SET ZZDT=Y
+34 ;
+35 KILL %DT
DO NOW^%DTC
SET %DT="RAEX"
SET %DT(0)=%
SET %DT("A")="Select the Date/Time to queue this job: "
+36 WRITE !
DO ^%DT
KILL %DT
IF $DATA(DTOUT)!(Y<0)
WRITE !!!?10,"Job not queued!"
QUIT
+37 SET ZTDTH=$GET(Y)
SET ZTSAVE("ZZDT")=""
SET ZTIO=""
SET ZTRTN="EN^PSOMAUEX"
SET ZTDESC="Auto expire of Rxs "
+38 DO ^%ZTLOAD
+39 if $DATA(ZTSK)
WRITE !!,"Task Queued !",!
+40 QUIT
EN ;
+1 NEW PSOSVDT
+2 SET PSOSVDT=""
+3 ; setting the end date to to today-1
SET X1=DT
SET X2=-1
DO C^%DTC
SET CDT=X
+4 FOR
SET ZZDT=$ORDER(^PSRX("AG",ZZDT))
if 'ZZDT!(ZZDT>CDT)
QUIT
DO EN1
SET PSOSVDT=ZZDT
+5 IF PSOSVDT>($PIECE(^PS(59.7,1,49.99),"^",8))
Begin DoDot:1
+6 SET DIE=59.7
SET DA=1
SET DR="49.95///"_PSOSVDT
DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+7 KILL PSOEXRX,PSOEXSTA,ZZDT,CDT,ORN,PIFN,PSUSD,PRFDT,PDA,PSDTEST
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+8 QUIT
EN1 ;
+1 FOR PSOEXRX=0:0
SET PSOEXRX=$ORDER(^PSRX("AG",ZZDT,PSOEXRX))
if 'PSOEXRX
QUIT
Begin DoDot:1
+2 if $PIECE($GET(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT
QUIT
+3 IF $DATA(^PSRX(PSOEXRX,0))
DO EN2
End DoDot:1
+4 QUIT
EN2 ;
+1 NEW CPRSDC,CPRSSTA
+2 SET CPRSDC=",1,7,12,13,"
+3 SET ORN=$PIECE($GET(^PSRX(PSOEXRX,"OR1")),"^",2)
SET CPRSSTA=""
+4 IF ORN
SET CPRSSTA=+$$STATUS^ORQOR2(ORN)
+5 SET DA=PSOEXRX
KILL CMOP
DO ^PSOCMOPA
+6 SET DA=$ORDER(^PS(52.5,"B",PSOEXRX,0))
+7 IF DA
IF $PIECE($GET(^PS(52.5,DA,0)),"^",2)
IF $PIECE($GET(^(0)),"^",3)
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
+8 IF $DATA(^PS(52.4,PSOEXRX,0))
SET DIK="^PS(52.4,"
SET DA=PSOEXRX
DO ^DIK
KILL DIK
+9 IF $GET(^PSRX(PSOEXRX,"H"))]""
if $PIECE(^PSRX(PSOEXRX,"H"),"^")
KILL ^PSRX("AH",$PIECE(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX)
SET ^PSRX(PSOEXRX,"H")=""
+10 SET PSOEXSTA=$PIECE($GET(^PSRX(PSOEXRX,"STA")),"^")
+11 ;
+12 IF PSOEXSTA=11
SET ORN=$PIECE($GET(^PSRX(PSOEXRX,"OR1")),"^",2)
IF ORN
IF CPRSDC'[(","_CPRSSTA_",")
Begin DoDot:1
+13 SET $PIECE(^PSRX(PSOEXRX,0),"^",19)=1
+14 DO EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
End DoDot:1
+15 ;
+16 IF PSOEXSTA=13
Begin DoDot:1
+17 IF 'ORN
DO EN^PSOHDR("PRES",PSOEXRX)
End DoDot:1
QUIT
+18 ;
+19 IF PSOEXSTA>9&(PSOEXSTA'=16)
QUIT
+20 ;
+21 IF +$PIECE($GET(^PSRX(PSOEXRX,2)),"^",6)
IF +$PIECE($GET(^(2)),"^",6)<DT
Begin DoDot:1
+22 SET $PIECE(^PSRX(PSOEXRX,"STA"),"^")=11
+23 SET (PIFN,PSUSD,PRFDT)=0
+24 FOR
SET PIFN=$ORDER(^PSRX(PSOEXRX,1,PIFN))
if 'PIFN
QUIT
SET PSUSD=PIFN
SET PRFDT=+$PIECE($GET(^PSRX(PSOEXRX,1,PIFN,0)),"^")
+25 DO REVERSE^PSOBPSU1(PSOEXRX,+PSUSD,"DE",5,"RX EXPIRED")
+26 IF $GET(PSUSD)
IF '$PIECE($GET(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18)
DO EN3
+27 SET ORN=$PIECE($GET(^PSRX(PSOEXRX,"OR1")),"^",2)
IF 'ORN
DO EN^PSOHDR("PRES",PSOEXRX)
QUIT
+28 ;If CPRS side already DC'd or expired, just send the expiration to the HDR
+29 IF CPRSDC[(","_CPRSSTA_",")
DO EN^PSOHDR("PRES",PSOEXRX)
QUIT
+30 SET $PIECE(^PSRX(PSOEXRX,0),"^",19)=1
+31 DO EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription past expiration date")
End DoDot:1
+32 QUIT
EN3 ;
+1 SET (PSDTEST,PDA)=0
FOR
SET PDA=$ORDER(^PSRX(PSOEXRX,"L",PDA))
if 'PDA
QUIT
if $PIECE($GET(^PSRX(PSOEXRX,"L",PDA,0)),"^",2)=PSUSD
SET PSDTEST=1
+2 if PSDTEST
QUIT
+3 IF $GET(CMOP(CMOP("L")))=""
IF ".L.X."[("."_$GET(CMOP("S"))_".")
SET PSDTEST=1
+4 NEW PSOORL
+5 SET PSOORL=$$LOCK1^ORX2(ORN)
if 'PSOORL
SET PSDTEST=1
IF PSOORL
DO UNLK1^ORX2(ORN)
+6 NEW PDAQ,PDA0
+7 SET PDAQ=0
+8 FOR PDA=0:0
SET PDA=$ORDER(^PSRX(PSOEXRX,4,PDA))
if 'PDA
QUIT
Begin DoDot:1
+9 SET PDA0=$GET(^PSRX(PSOEXRX,4,PDA,0))
if PDA0=""
QUIT
+10 IF $PIECE(PDA0,"^",3)=PSUSD
SET PSDTEST=1
End DoDot:1
ENX IF 'PSDTEST
KILL ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD)
DO NSET
+1 QUIT
NSET ;
+1 NEW PSONM,PSONMX
+2 SET PSONM=""
FOR PSONMX=0:0
SET PSONMX=$ORDER(^PSRX(PSOEXRX,1,PSONMX))
if 'PSONMX
QUIT
SET PSONM=PSONMX
+3 SET ^PSRX(PSOEXRX,1,0)="^52.1DA^"_$GET(PSONM)_"^"_$GET(PSONM)
+4 QUIT
