PSO293PI ;BIR/MFR-EXPIRATION DATE CLEAN UP ;05/03/07
;;7.0;OUTPATIENT PHARMACY;**293**;DEC 1997;Build 22
;External references ^DPT supported by DBIA 10035
;External reference to STATUS^ORQOR2 is supported by DBIA 3458
;External reference to ^PS(59.7 is supported by DBIA 694
N NMSP,JOBSTS,DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y,ACTION,EXPJOBDT,PSODUZ
S NMSP="PSO293PI"
;
S JOBSTS=$$JOBSTS^PSO293P1()
;
W !?5,"Expiration Date clean up job for Outpatient Pharamcy prescriptions"
W !?5,"=================================================================="
W !?5,"Current status: "
W:JOBSTS="N" "NEVER RUN"
W:JOBSTS="S" "STOPPED ON "_$$FMTE^XLFDT($G(^XTMP(NMSP,"STOPPED")))
W:JOBSTS="R" "RUNNING"
W:JOBSTS="C" "COMPLETED ON "_$$FMTE^XLFDT($G(^XTMP(NMSP,"COMPLETED")))
W:JOBSTS="U" "UNKNOWN"
W:$G(^XTMP(NMSP,"LASTRX")) " (Last Rx IEN: "_+$G(^XTMP(NMSP,"LASTRX"))_")"
;
S DIR(0)="SO^",DIR("A")=""
I JOBSTS="N" D
.S DIR(0)=DIR(0)_"ST:START CLEAN UP JOB;",DIR("A")=DIR("A")_"(ST)Start,",DIR("B")="START"
I JOBSTS="S" D
. S DIR(0)=DIR(0)_"RE:RESUME CLEAN UP JOB;",DIR("A")=DIR("A")_"(RE)Resume,"
I JOBSTS="R" D
. S DIR(0)=DIR(0)_"SP:STOP CLEAN UP JOB;",DIR("A")=DIR("A")_"(SP)Stop,"
I JOBSTS="C" D
. S DIR(0)=DIR(0)_"RR:RE-RUN CLEAN UP JOB;",DIR("A")=DIR("A")_"(RR)Re-run,"
S DIR(0)=DIR(0)_"VW:VIEW "_$S(JOBSTS'="C":"PARTIAL ",1:"")_"CLEAN UP JOB RESULTS;"
S DIR("A")=DIR("A")_"(VW)View,",DIR("B")="VIEW"
S DIR(0)=DIR(0)_"QT:QUIT",DIR("A")=DIR("A")_"(QT)Quit"
D ^DIR I $D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT) G QUIT
S ACTION=Y
;
I ACTION="SP" W !!,"This may take a few minutes, please wait..." D G QUIT
. N TIME,UNABLE
. S ^XTMP(NMSP,"STOP")=1,(TIME,UNABLE)=0
. F Q:$D(^XTMP(NMSP,"STOPPED")) D Q:UNABLE
. . H 1 S TIME=TIME+1
. . I '$D(^XTMP(NMSP,"STOPPED")) D
. . . I $D(^XTMP(NMSP,"COMPLETED"))!($$JOBSTS^PSO293P1()'="R")!(TIME>600) S UNABLE=1
;
I ACTION="QT" G QUIT
I ACTION="VW" D DISPLAY^PSO293P1 G QUIT
;
D JOB^PSO293P1()
Q
;
PI ; Post-Install entry point
N EXPJOBDT,NMSP
S NMSP="PSO293PI"
D LOG^PSO293P1("PATCH INSTALLATION")
S EXPJOBDT=$$GET1^DIQ(59.7,1,49.95,"I")
I 'EXPJOBDT D
. S EXPJOBDT=$$FMADD^XLFDT($$DT^XLFDT(),-2)
. S $P(^PS(59.7,1,49.99),"^",8)=EXPJOBDT
. D LOG^PSO293P1("DATE AUTO-EXPIRE set: "_$$FMTE^XLFDT(EXPJOBDT,2))
S ^XTMP(NMSP,"EXPJOBDT")=EXPJOBDT
;
D JOB^PSO293P1($$NOW^XLFDT())
Q
;
EN ;
N NMSP,PSOINST,CUTOFF,PSOACT,RXP,STOP,PSOINACT,PATIENT,COUNTER,RXP,DRUG,STATUS
N ISSUEDT,EXPIRDT,BADRXCNT,DAYSSUP,NUMREFS,PSOPROD,LASTCNT,I
;
S NMSP="PSO293PI" I '$G(PSODUZ) S PSODUZ=+$G(DUZ)
;
; - If can't get Lock, then already running.
L +^XTMP(NMSP):5 I '$T D LOG^PSO293P1("UNSUCCESSFUL (LOCKED)") G QUIT
;
D SETXTMP
;
I '$G(DT) S DT=$$DT^XLFDT
S PSOPROD=$$PROD^XUPROD()
;
S PSOINST=$P($$SITE^VASITE(),"^",2)_" ("_+$$SITE^VASITE()_")"
S CUTOFF=$$GET1^DIQ(59.7,1,49.95,"I") I 'CUTOFF S CUTOFF=$$FMADD^XLFDT(DT,-2)
S PSOINACT=",11,12,13,14,15,"
S RXP=+$G(^XTMP(NMSP,"LASTRX"))
I $G(ACTION)="RE" D
. F I=2:1:12,14 S BADRXCNT(14)=+$G(^XTMP(NMSP,I))
S LASTCNT=+$G(BADRXCNT(14)),STOP=0
F COUNTER=LASTCNT:1 S RXP=$O(^PSRX(RXP)) Q:'RXP D Q:STOP
. S:'(COUNTER#10000) DT=$$DT^XLFDT()
. S PATIENT=$P($G(^PSRX(RXP,0)),"^",2)
. S DRUG=$P($G(^PSRX(RXP,0)),"^",6)
. S STATUS=$P($G(^PSRX(RXP,"STA")),"^")
. S ISSUEDT=$P($G(^PSRX(RXP,0)),"^",13)
. S DAYSSUP=$P($G(^PSRX(RXP,0)),"^",8)
. S NUMREFS=$P($G(^PSRX(RXP,0)),"^",9)
. S EXPIRDT=$P($G(^PSRX(RXP,2)),"^",6)
. S BADRXCNT(14)=$G(BADRXCNT(14))+1
. S BADRXCNT("LASTRX")=RXP_"^"_COUNTER
. ;--- SKIP bad Rx's
. I ('PATIENT!'DRUG) Q
. I '$D(^DPT(PATIENT))!('$D(^PSDRUG(DRUG))) Q
. I 'ISSUEDT Q
. ;---
. D SET
. ;---
. I '(COUNTER#5000) D
. . M ^XTMP(NMSP)=BADRXCNT
. . I $G(^XTMP(NMSP,"STOP")) S STOP=1
;
I STOP D STOP G QUIT
;
M ^XTMP(NMSP)=BADRXCNT
S ^XTMP(NMSP,"COMPLETED")=$$NOW^XLFDT()
K ^XTMP(NMSP,"LASTRX")
D LOG^PSO293P1("COMPLETED")
D MAIL^PSO293P1
;
QUIT ;
L -^XTMP(NMSP)
Q
;
STOP ;
K ^XTMP(NMSP,"STOP")
S ^XTMP(NMSP,"STOPPED")=$$NOW^XLFDT()
D LOG^PSO293P1("STOPPED")
D MAIL^PSO293P1
Q
;
SET ;
N CPRSDC,CPRSTA,NEWEXPDT,DA,DIE,ORN,DR
S CPRSDC=",1,7,12,13,"
;
; --- No expiration date on PRESCRIPTION file (#52)
I EXPIRDT="" D Q
. S ORN=$$CPRSNUM(RXP),CPRSTA=$P(ORN,"^",2),ORN=+ORN
. D SETEXP^PSO293P1 I '$G(EXPIRDT) Q
. I EXPIRDT>CUTOFF D Q ; Expiration Date past Cutoff (will be exp. by auto exp. job), Quit
. . S BADRXCNT(2)=$G(BADRXCNT(2))+1,^XTMP(NMSP,2,RXP)=""
. . D SENDHDR
. I PSOINACT'[(","_STATUS_",") D ; Foce expiration of Rx (Past Exp. Date)
. . S DA=RXP,DIE=52,DR="100///11",STATUS=11
. . D ^DIE K DIE,DR
. . D RXACT^PSOBPSU2(RXP,0,"Rx status set to EXPIRED by PSO*7*293","E",PSODUZ)
. I ORN D Q ; Rx is expired in CPRS (Update HDR with Exp. Date), Quit
. . I CPRSDC'[(","_CPRSTA_","),'$D(^PS(52.41,"AQ",RXP)) D Q
. . . S BADRXCNT(3)=$G(BADRXCNT(3))+1,^XTMP(NMSP,3,RXP)=""
. . . D SENDCPRS()
. . S BADRXCNT(4)=$G(BADRXCNT(4))+1,^XTMP(NMSP,4,RXP)=""
. . D SENDHDR
. I 'ORN D ; No CPRS Order # (Update HDR with Exp. Date)
. . S BADRXCNT(5)=$G(BADRXCNT(5))+1,^XTMP(NMSP,5,RXP)=""
. . D SENDHDR
;
; --- Rx is expired. Update CPRS and HDR if necessary
I STATUS=11 D Q
. S ORN=$$CPRSNUM(RXP),CPRSTA=$P(ORN,"^",2),ORN=+ORN
. S NEWEXPDT=0
. I $$FMDIFF^XLFDT(EXPIRDT,ISSUEDT,1)>366 D ; Expiration Date is > 366, Recalculate new Date
. . S NEWEXPDT=1 D SETEXP^PSO293P1
. I ORN,CPRSDC'[(","_CPRSTA_","),'$D(^PS(52.41,"AQ",RXP)) D ; Rx is not expired in CPRS (Update CPRS/HDR with Exp. Date), Quit
. . I 'NEWEXPDT S BADRXCNT(6)=$G(BADRXCNT(6))+1,^XTMP(NMSP,6,RXP)=""
. . I NEWEXPDT S BADRXCNT(7)=$G(BADRXCNT(7))+1,^XTMP(NMSP,7,RXP)=""
. . D SENDCPRS()
. I 'NEWEXPDT Q ; Expiration Date was not recalculated, don't send to HDR
. S BADRXCNT(8)=$G(BADRXCNT(8))+1,^XTMP(NMSP,8,RXP)=""
. D SENDHDR
;
I EXPIRDT<CUTOFF,(PSOINACT'[(","_STATUS_",")) D ; Rx is past exp. date but is still on a non-Expired/DC'd status
. S DA=RXP ; Note: Rx's expiring on or after the CUTOFF will be picked up
. S DIE=52,DR="100///11",STATUS=11 ; by the Auto Expiration Job.
. D ^DIE K DIE,DR
. D RXACT^PSOBPSU2(RXP,0,"Rx status set to EXPIRED by PSO*7*293","E",PSODUZ)
. S ORN=$$CPRSNUM(RXP),CPRSTA=$P(ORN,"^",2),ORN=+ORN
. I ORN,CPRSDC'[(","_CPRSTA_",") D Q ; Update CPRS if necessary, this will also call HDR
. . S BADRXCNT(9)=$G(BADRXCNT(9))+1,^XTMP(NMSP,9,RXP)=""
. . D SENDCPRS()
. I ORN D Q ; If CPRS was not updated, call HDR if there is an Order #
. . S BADRXCNT(10)=$G(BADRXCNT(10))+1,^XTMP(NMSP,10,RXP)=""
. . D SENDHDR
. I 'ORN D ; If no CPRS Order #, just report (no updates to CPRS/HDR)
. . S BADRXCNT(11)=$G(BADRXCNT(11))+1
. . S ^XTMP(NMSP,11,RXP)=""
;
I STATUS=13 D Q
. S ORN=+$$CPRSNUM(RXP)
. I 'ORN D
. . S BADRXCNT(12)=$G(BADRXCNT(12))+1,^XTMP(NMSP,12,RXP)=""
. . D SENDHDR
Q
;
CPRSNUM(RXP) ;
N ORN,STA
S ORN=$P($G(^PSRX(RXP,"OR1")),"^",2),STA=""
I ORN S STA=+$$STATUS^ORQOR2(ORN) I STA=0 S ORN=""
Q (ORN_"^"_STA)
;
SETXTMP ; - Initialize the XTMP global
I $D(^XTMP(NMSP,"STARTED")) D
. S ^XTMP(NMSP,"RE-STARTED")=$$NOW^XLFDT() D LOG^PSO293P1("RESUMED")
I '$D(^XTMP(NMSP,"STARTED")) D
. S ^XTMP(NMSP,"STARTED")=$$NOW^XLFDT() D LOG^PSO293P1("STARTED")
K ^XTMP(NMSP,"STOP"),^XTMP(NMSP,"STOPPED")
S ^XTMP(NMSP,0)=$$FMADD^XLFDT($$NOW^XLFDT(),730)_"^"_$$NOW^XLFDT()_"^PSO*7*293 - RX EXPIRATION DATE CLEAN UP"
Q
;
SENDCPRS(CPRSONLY) ; Update CPRS/HDR
N PSOSSMES,TYPE,STS,STSCOM
S:$G(CPRSONLY) PSOSSMES="CPRSUP"
;
S TYPE="SC",STS="DC",STSCOM="Discontinued"
I STATUS=11 S $P(^PSRX(RXP,0),"^",19)=1,STS="ZE",STSCOM="Expired"
I STATUS=13 S TYPE="OC",STS="",STSCOM="Deleted"
I STATUS=14 S TYPE="OD",STS="RP",STSCOM="Discontinued/Edited"
D EN^PSOHLSN1(RXP,TYPE,STS,"Prescription is "_STSCOM_".")
Q
;
SENDHDR ; Update HDR only
D:$G(PSOPROD) EN^PSOHDR("PRES",RXP)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO293PI 8281 printed Nov 22, 2024@17:32:51 Page 2
PSO293PI ;BIR/MFR-EXPIRATION DATE CLEAN UP ;05/03/07
+1 ;;7.0;OUTPATIENT PHARMACY;**293**;DEC 1997;Build 22
+2 ;External references ^DPT supported by DBIA 10035
+3 ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
+4 ;External reference to ^PS(59.7 is supported by DBIA 694
+5 NEW NMSP,JOBSTS,DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y,ACTION,EXPJOBDT,PSODUZ
+6 SET NMSP="PSO293PI"
+7 ;
+8 SET JOBSTS=$$JOBSTS^PSO293P1()
+9 ;
+10 WRITE !?5,"Expiration Date clean up job for Outpatient Pharamcy prescriptions"
+11 WRITE !?5,"=================================================================="
+12 WRITE !?5,"Current status: "
+13 if JOBSTS="N"
WRITE "NEVER RUN"
+14 if JOBSTS="S"
WRITE "STOPPED ON "_$$FMTE^XLFDT($GET(^XTMP(NMSP,"STOPPED")))
+15 if JOBSTS="R"
WRITE "RUNNING"
+16 if JOBSTS="C"
WRITE "COMPLETED ON "_$$FMTE^XLFDT($GET(^XTMP(NMSP,"COMPLETED")))
+17 if JOBSTS="U"
WRITE "UNKNOWN"
+18 if $GET(^XTMP(NMSP,"LASTRX"))
WRITE " (Last Rx IEN: "_+$GET(^XTMP(NMSP,"LASTRX"))_")"
+19 ;
+20 SET DIR(0)="SO^"
SET DIR("A")=""
+21 IF JOBSTS="N"
Begin DoDot:1
+22 SET DIR(0)=DIR(0)_"ST:START CLEAN UP JOB;"
SET DIR("A")=DIR("A")_"(ST)Start,"
SET DIR("B")="START"
End DoDot:1
+23 IF JOBSTS="S"
Begin DoDot:1
+24 SET DIR(0)=DIR(0)_"RE:RESUME CLEAN UP JOB;"
SET DIR("A")=DIR("A")_"(RE)Resume,"
End DoDot:1
+25 IF JOBSTS="R"
Begin DoDot:1
+26 SET DIR(0)=DIR(0)_"SP:STOP CLEAN UP JOB;"
SET DIR("A")=DIR("A")_"(SP)Stop,"
End DoDot:1
+27 IF JOBSTS="C"
Begin DoDot:1
+28 SET DIR(0)=DIR(0)_"RR:RE-RUN CLEAN UP JOB;"
SET DIR("A")=DIR("A")_"(RR)Re-run,"
End DoDot:1
+29 SET DIR(0)=DIR(0)_"VW:VIEW "_$SELECT(JOBSTS'="C":"PARTIAL ",1:"")_"CLEAN UP JOB RESULTS;"
+30 SET DIR("A")=DIR("A")_"(VW)View,"
SET DIR("B")="VIEW"
+31 SET DIR(0)=DIR(0)_"QT:QUIT"
SET DIR("A")=DIR("A")_"(QT)Quit"
+32 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)
GOTO QUIT
+33 SET ACTION=Y
+34 ;
+35 IF ACTION="SP"
WRITE !!,"This may take a few minutes, please wait..."
Begin DoDot:1
+36 NEW TIME,UNABLE
+37 SET ^XTMP(NMSP,"STOP")=1
SET (TIME,UNABLE)=0
+38 FOR
if $DATA(^XTMP(NMSP,"STOPPED"))
QUIT
Begin DoDot:2
+39 HANG 1
SET TIME=TIME+1
+40 IF '$DATA(^XTMP(NMSP,"STOPPED"))
Begin DoDot:3
+41 IF $DATA(^XTMP(NMSP,"COMPLETED"))!($$JOBSTS^PSO293P1()'="R")!(TIME>600)
SET UNABLE=1
End DoDot:3
End DoDot:2
if UNABLE
QUIT
End DoDot:1
GOTO QUIT
+42 ;
+43 IF ACTION="QT"
GOTO QUIT
+44 IF ACTION="VW"
DO DISPLAY^PSO293P1
GOTO QUIT
+45 ;
+46 DO JOB^PSO293P1()
+47 QUIT
+48 ;
PI ; Post-Install entry point
+1 NEW EXPJOBDT,NMSP
+2 SET NMSP="PSO293PI"
+3 DO LOG^PSO293P1("PATCH INSTALLATION")
+4 SET EXPJOBDT=$$GET1^DIQ(59.7,1,49.95,"I")
+5 IF 'EXPJOBDT
Begin DoDot:1
+6 SET EXPJOBDT=$$FMADD^XLFDT($$DT^XLFDT(),-2)
+7 SET $PIECE(^PS(59.7,1,49.99),"^",8)=EXPJOBDT
+8 DO LOG^PSO293P1("DATE AUTO-EXPIRE set: "_$$FMTE^XLFDT(EXPJOBDT,2))
End DoDot:1
+9 SET ^XTMP(NMSP,"EXPJOBDT")=EXPJOBDT
+10 ;
+11 DO JOB^PSO293P1($$NOW^XLFDT())
+12 QUIT
+13 ;
EN ;
+1 NEW NMSP,PSOINST,CUTOFF,PSOACT,RXP,STOP,PSOINACT,PATIENT,COUNTER,RXP,DRUG,STATUS
+2 NEW ISSUEDT,EXPIRDT,BADRXCNT,DAYSSUP,NUMREFS,PSOPROD,LASTCNT,I
+3 ;
+4 SET NMSP="PSO293PI"
IF '$GET(PSODUZ)
SET PSODUZ=+$GET(DUZ)
+5 ;
+6 ; - If can't get Lock, then already running.
+7 LOCK +^XTMP(NMSP):5
IF '$TEST
DO LOG^PSO293P1("UNSUCCESSFUL (LOCKED)")
GOTO QUIT
+8 ;
+9 DO SETXTMP
+10 ;
+11 IF '$GET(DT)
SET DT=$$DT^XLFDT
+12 SET PSOPROD=$$PROD^XUPROD()
+13 ;
+14 SET PSOINST=$PIECE($$SITE^VASITE(),"^",2)_" ("_+$$SITE^VASITE()_")"
+15 SET CUTOFF=$$GET1^DIQ(59.7,1,49.95,"I")
IF 'CUTOFF
SET CUTOFF=$$FMADD^XLFDT(DT,-2)
+16 SET PSOINACT=",11,12,13,14,15,"
+17 SET RXP=+$GET(^XTMP(NMSP,"LASTRX"))
+18 IF $GET(ACTION)="RE"
Begin DoDot:1
+19 FOR I=2:1:12,14
SET BADRXCNT(14)=+$GET(^XTMP(NMSP,I))
End DoDot:1
+20 SET LASTCNT=+$GET(BADRXCNT(14))
SET STOP=0
+21 FOR COUNTER=LASTCNT:1
SET RXP=$ORDER(^PSRX(RXP))
if 'RXP
QUIT
Begin DoDot:1
+22 if '(COUNTER#10000)
SET DT=$$DT^XLFDT()
+23 SET PATIENT=$PIECE($GET(^PSRX(RXP,0)),"^",2)
+24 SET DRUG=$PIECE($GET(^PSRX(RXP,0)),"^",6)
+25 SET STATUS=$PIECE($GET(^PSRX(RXP,"STA")),"^")
+26 SET ISSUEDT=$PIECE($GET(^PSRX(RXP,0)),"^",13)
+27 SET DAYSSUP=$PIECE($GET(^PSRX(RXP,0)),"^",8)
+28 SET NUMREFS=$PIECE($GET(^PSRX(RXP,0)),"^",9)
+29 SET EXPIRDT=$PIECE($GET(^PSRX(RXP,2)),"^",6)
+30 SET BADRXCNT(14)=$GET(BADRXCNT(14))+1
+31 SET BADRXCNT("LASTRX")=RXP_"^"_COUNTER
+32 ;--- SKIP bad Rx's
+33 IF ('PATIENT!'DRUG)
QUIT
+34 IF '$DATA(^DPT(PATIENT))!('$DATA(^PSDRUG(DRUG)))
QUIT
+35 IF 'ISSUEDT
QUIT
+36 ;---
+37 DO SET
+38 ;---
+39 IF '(COUNTER#5000)
Begin DoDot:2
+40 MERGE ^XTMP(NMSP)=BADRXCNT
+41 IF $GET(^XTMP(NMSP,"STOP"))
SET STOP=1
End DoDot:2
End DoDot:1
if STOP
QUIT
+42 ;
+43 IF STOP
DO STOP
GOTO QUIT
+44 ;
+45 MERGE ^XTMP(NMSP)=BADRXCNT
+46 SET ^XTMP(NMSP,"COMPLETED")=$$NOW^XLFDT()
+47 KILL ^XTMP(NMSP,"LASTRX")
+48 DO LOG^PSO293P1("COMPLETED")
+49 DO MAIL^PSO293P1
+50 ;
QUIT ;
+1 LOCK -^XTMP(NMSP)
+2 QUIT
+3 ;
STOP ;
+1 KILL ^XTMP(NMSP,"STOP")
+2 SET ^XTMP(NMSP,"STOPPED")=$$NOW^XLFDT()
+3 DO LOG^PSO293P1("STOPPED")
+4 DO MAIL^PSO293P1
+5 QUIT
+6 ;
SET ;
+1 NEW CPRSDC,CPRSTA,NEWEXPDT,DA,DIE,ORN,DR
+2 SET CPRSDC=",1,7,12,13,"
+3 ;
+4 ; --- No expiration date on PRESCRIPTION file (#52)
+5 IF EXPIRDT=""
Begin DoDot:1
+6 SET ORN=$$CPRSNUM(RXP)
SET CPRSTA=$PIECE(ORN,"^",2)
SET ORN=+ORN
+7 DO SETEXP^PSO293P1
IF '$GET(EXPIRDT)
QUIT
+8 ; Expiration Date past Cutoff (will be exp. by auto exp. job), Quit
IF EXPIRDT>CUTOFF
Begin DoDot:2
+9 SET BADRXCNT(2)=$GET(BADRXCNT(2))+1
SET ^XTMP(NMSP,2,RXP)=""
+10 DO SENDHDR
End DoDot:2
QUIT
+11 ; Foce expiration of Rx (Past Exp. Date)
IF PSOINACT'[(","_STATUS_",")
Begin DoDot:2
+12 SET DA=RXP
SET DIE=52
SET DR="100///11"
SET STATUS=11
+13 DO ^DIE
KILL DIE,DR
+14 DO RXACT^PSOBPSU2(RXP,0,"Rx status set to EXPIRED by PSO*7*293","E",PSODUZ)
End DoDot:2
+15 ; Rx is expired in CPRS (Update HDR with Exp. Date), Quit
IF ORN
Begin DoDot:2
+16 IF CPRSDC'[(","_CPRSTA_",")
IF '$DATA(^PS(52.41,"AQ",RXP))
Begin DoDot:3
+17 SET BADRXCNT(3)=$GET(BADRXCNT(3))+1
SET ^XTMP(NMSP,3,RXP)=""
+18 DO SENDCPRS()
End DoDot:3
QUIT
+19 SET BADRXCNT(4)=$GET(BADRXCNT(4))+1
SET ^XTMP(NMSP,4,RXP)=""
+20 DO SENDHDR
End DoDot:2
QUIT
+21 ; No CPRS Order # (Update HDR with Exp. Date)
IF 'ORN
Begin DoDot:2
+22 SET BADRXCNT(5)=$GET(BADRXCNT(5))+1
SET ^XTMP(NMSP,5,RXP)=""
+23 DO SENDHDR
End DoDot:2
End DoDot:1
QUIT
+24 ;
+25 ; --- Rx is expired. Update CPRS and HDR if necessary
+26 IF STATUS=11
Begin DoDot:1
+27 SET ORN=$$CPRSNUM(RXP)
SET CPRSTA=$PIECE(ORN,"^",2)
SET ORN=+ORN
+28 SET NEWEXPDT=0
+29 ; Expiration Date is > 366, Recalculate new Date
IF $$FMDIFF^XLFDT(EXPIRDT,ISSUEDT,1)>366
Begin DoDot:2
+30 SET NEWEXPDT=1
DO SETEXP^PSO293P1
End DoDot:2
+31 ; Rx is not expired in CPRS (Update CPRS/HDR with Exp. Date), Quit
IF ORN
IF CPRSDC'[(","_CPRSTA_",")
IF '$DATA(^PS(52.41,"AQ",RXP))
Begin DoDot:2
+32 IF 'NEWEXPDT
SET BADRXCNT(6)=$GET(BADRXCNT(6))+1
SET ^XTMP(NMSP,6,RXP)=""
+33 IF NEWEXPDT
SET BADRXCNT(7)=$GET(BADRXCNT(7))+1
SET ^XTMP(NMSP,7,RXP)=""
+34 DO SENDCPRS()
End DoDot:2
+35 ; Expiration Date was not recalculated, don't send to HDR
IF 'NEWEXPDT
QUIT
+36 SET BADRXCNT(8)=$GET(BADRXCNT(8))+1
SET ^XTMP(NMSP,8,RXP)=""
+37 DO SENDHDR
End DoDot:1
QUIT
+38 ;
+39 ; Rx is past exp. date but is still on a non-Expired/DC'd status
IF EXPIRDT<CUTOFF
IF (PSOINACT'[(","_STATUS_","))
Begin DoDot:1
+40 ; Note: Rx's expiring on or after the CUTOFF will be picked up
SET DA=RXP
+41 ; by the Auto Expiration Job.
SET DIE=52
SET DR="100///11"
SET STATUS=11
+42 DO ^DIE
KILL DIE,DR
+43 DO RXACT^PSOBPSU2(RXP,0,"Rx status set to EXPIRED by PSO*7*293","E",PSODUZ)
+44 SET ORN=$$CPRSNUM(RXP)
SET CPRSTA=$PIECE(ORN,"^",2)
SET ORN=+ORN
+45 ; Update CPRS if necessary, this will also call HDR
IF ORN
IF CPRSDC'[(","_CPRSTA_",")
Begin DoDot:2
+46 SET BADRXCNT(9)=$GET(BADRXCNT(9))+1
SET ^XTMP(NMSP,9,RXP)=""
+47 DO SENDCPRS()
End DoDot:2
QUIT
+48 ; If CPRS was not updated, call HDR if there is an Order #
IF ORN
Begin DoDot:2
+49 SET BADRXCNT(10)=$GET(BADRXCNT(10))+1
SET ^XTMP(NMSP,10,RXP)=""
+50 DO SENDHDR
End DoDot:2
QUIT
+51 ; If no CPRS Order #, just report (no updates to CPRS/HDR)
IF 'ORN
Begin DoDot:2
+52 SET BADRXCNT(11)=$GET(BADRXCNT(11))+1
+53 SET ^XTMP(NMSP,11,RXP)=""
End DoDot:2
End DoDot:1
+54 ;
+55 IF STATUS=13
Begin DoDot:1
+56 SET ORN=+$$CPRSNUM(RXP)
+57 IF 'ORN
Begin DoDot:2
+58 SET BADRXCNT(12)=$GET(BADRXCNT(12))+1
SET ^XTMP(NMSP,12,RXP)=""
+59 DO SENDHDR
End DoDot:2
End DoDot:1
QUIT
+60 QUIT
+61 ;
CPRSNUM(RXP) ;
+1 NEW ORN,STA
+2 SET ORN=$PIECE($GET(^PSRX(RXP,"OR1")),"^",2)
SET STA=""
+3 IF ORN
SET STA=+$$STATUS^ORQOR2(ORN)
IF STA=0
SET ORN=""
+4 QUIT (ORN_"^"_STA)
+5 ;
SETXTMP ; - Initialize the XTMP global
+1 IF $DATA(^XTMP(NMSP,"STARTED"))
Begin DoDot:1
+2 SET ^XTMP(NMSP,"RE-STARTED")=$$NOW^XLFDT()
DO LOG^PSO293P1("RESUMED")
End DoDot:1
+3 IF '$DATA(^XTMP(NMSP,"STARTED"))
Begin DoDot:1
+4 SET ^XTMP(NMSP,"STARTED")=$$NOW^XLFDT()
DO LOG^PSO293P1("STARTED")
End DoDot:1
+5 KILL ^XTMP(NMSP,"STOP"),^XTMP(NMSP,"STOPPED")
+6 SET ^XTMP(NMSP,0)=$$FMADD^XLFDT($$NOW^XLFDT(),730)_"^"_$$NOW^XLFDT()_"^PSO*7*293 - RX EXPIRATION DATE CLEAN UP"
+7 QUIT
+8 ;
SENDCPRS(CPRSONLY) ; Update CPRS/HDR
+1 NEW PSOSSMES,TYPE,STS,STSCOM
+2 if $GET(CPRSONLY)
SET PSOSSMES="CPRSUP"
+3 ;
+4 SET TYPE="SC"
SET STS="DC"
SET STSCOM="Discontinued"
+5 IF STATUS=11
SET $PIECE(^PSRX(RXP,0),"^",19)=1
SET STS="ZE"
SET STSCOM="Expired"
+6 IF STATUS=13
SET TYPE="OC"
SET STS=""
SET STSCOM="Deleted"
+7 IF STATUS=14
SET TYPE="OD"
SET STS="RP"
SET STSCOM="Discontinued/Edited"
+8 DO EN^PSOHLSN1(RXP,TYPE,STS,"Prescription is "_STSCOM_".")
+9 QUIT
+10 ;
SENDHDR ; Update HDR only
+1 if $GET(PSOPROD)
DO EN^PSOHDR("PRES",RXP)
+2 QUIT
