- 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
- 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
