PSO283PI ;BIR/MFR-EXPIRATION DATE PROBLEM TALLY ;05/03/07
;;7.0;OUTPATIENT PHARMACY;**283**;DEC 1997;Build 28
;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,Y,ACTION,EXPJOBDT,PSODUZ
S NMSP="PSO283PI"
;
S JOBSTS=$$JOBSTS^PSO283P1()
;
W !?5,"Expiration Date problem tally patch for Outpatient Pharmacy 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:$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 TALLY JOB;",DIR("A")=DIR("A")_"(ST)Start,",DIR("B")="START"
I JOBSTS="S" D
. S DIR(0)=DIR(0)_"RE:RESUME TALLY JOB;",DIR("A")=DIR("A")_"(RE)Resume,"
I JOBSTS="R" D
. S DIR(0)=DIR(0)_"SP:STOP TALLY JOB;",DIR("A")=DIR("A")_"(SP)Stop,"
I JOBSTS="C" D
. S DIR(0)=DIR(0)_"RR:RE-RUN TALLY JOB;",DIR("A")=DIR("A")_"(RR)Re-run,"
S DIR(0)=DIR(0)_"VW:VIEW "_$S(JOBSTS'="C":"PARTIAL ",1:"")_"TALLY 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 !!,"Stopping..." 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,"COMPLETED"))!($$JOBSTS^PSO283P1()'="R")!(TIME>30) S UNABLE=1
. W $S(UNABLE:"NOT OK (may no longer be running)",1:"OK")
. K ^XTMP(NMSP,"STOP")
;
I ACTION="QT" G QUIT
I ACTION="VW" D DISPLAY^PSO283P1 G QUIT
I ACTION="RR" K ^XTMP(NMSP)
;
D JOB^PSO283P1()
Q
;
PI ; Post-Install entry point
N EXPJOBDT,NMSP
S NMSP="PSO283PI" K ^XTMP(NMSP)
D LOG^PSO283P1("PATCH INSTALLATION")
D JOB^PSO283P1($$NOW^XLFDT())
Q
;
EN ;
N NMSP,PSOINST,CUTOFF,PSOACT,RXP,STOP,PSOINACT,PATIENT,COUNTER,RXP,PATICN,DRUG,STATUS
N ISSUEDT,EXPIRDT,BADRXCNT,DAYSSUP,NUMREFS
;
S NMSP="PSO283PI" I '$G(PSODUZ) S PSODUZ=+$G(DUZ)
;
; - If can't get Lock, then already running.
L +^XTMP(NMSP):5 I '$T D LOG^PSO283P1("UNSUCCESSFUL (LOCKED)") G QUIT
;
D SETXTMP
;
I '$G(DT) S DT=$$DT^XLFDT
;
S PSOINST=$P($$SITE^VASITE(),"^",2)_" ("_+$$SITE^VASITE()_")"
S CUTOFF=$$FMADD^XLFDT(DT,-2)
S PSOINACT=",11,12,13,14,15,"
S RXP=+$G(^XTMP(NMSP,0,"LASTRX")),STOP=0
F COUNTER=1:1 S RXP=$O(^PSRX(RXP)) Q:'RXP D Q:STOP
. S:'(COUNTER#100000) DT=$$DT^XLFDT()
. S PATIENT=$P($G(^PSRX(RXP,0)),"^",2)
. S PATICN=$P($$GETICN^MPIF001(PATIENT),"^")
. 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
. ;--- eliminate bad Rx's
. I ('PATIENT!'DRUG) S BADRXCNT(13)=$G(BADRXCNT(13))+1 Q
. I '$D(^DPT(PATIENT))!('$D(^PSDRUG(DRUG))) S BADRXCNT(13)=$G(BADRXCNT(13))+1 Q
. I 'ISSUEDT S BADRXCNT(13)=$G(BADRXCNT(13))+1 Q
. ;---
. D SET
. ;---
. I '(COUNTER#10000) 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^PSO283P1("COMPLETED")
D MAIL^PSO283P1
;
QUIT ;
L -^XTMP(NMSP)
Q
;
STOP ;
K ^XTMP(NMSP,"STOP")
S ^XTMP(NMSP,"STOPPED")=$$NOW^XLFDT()
D LOG^PSO283P1("STOPPED")
D MAIL^PSO283P1
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 CALCEXP^PSO283P1 I '$G(EXPIRDT) Q
. I EXPIRDT>CUTOFF D Q ; Expiration Date past Cutoff (will be exp. by auto exp. job), Quit
. . I PATICN=-1 D Q ; NO ICN# - DO NOT send it to HDR
. . . S BADRXCNT(102)=$G(BADRXCNT(102))+1
. . . S ^XTMP(NMSP,102,RXP,"HDR")=""
. . S BADRXCNT(2)=$G(BADRXCNT(2))+1,^XTMP(NMSP,2,RXP)=""
. I ORN D Q ; Rx is expired in CPRS (Update HDR with Exp. Date), Quit
. . I PATICN=-1 D Q ; NO ICN# - DO NOT send it to HDR
. . . I CPRSDC'[(","_CPRSTA_",") D
. . . . S ^XTMP(NMSP,103,RXP,"HDR")="",BADRXCNT(103)=$G(BADRXCNT(103))+1
. . . I CPRSDC[(","_CPRSTA_",") D
. . . . S ^XTMP(NMSP,104,RXP,"HDR")="",BADRXCNT(104)=$G(BADRXCNT(104))+1
. . I CPRSDC'[(","_CPRSTA_",") D Q
. . . S BADRXCNT(3)=$G(BADRXCNT(3))+1,^XTMP(NMSP,3,RXP)=""
. . S BADRXCNT(4)=$G(BADRXCNT(4))+1,^XTMP(NMSP,4,RXP)=""
. I 'ORN D ; No CPRS Order # (Update HDR with Exp. Date)
. . I PATICN=-1 D Q ; NO ICN# - DO NOT send it to HDR
. . . S BADRXCNT(105)=$G(BADRXCNT(105))+1
. . . S ^XTMP(NMSP,105,RXP,"HDR")=""
. . S BADRXCNT(5)=$G(BADRXCNT(5))+1,^XTMP(NMSP,5,RXP)=""
;
; --- 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 CALCEXP^PSO283P1
. I ORN,CPRSDC'[(","_CPRSTA_",") D ; Rx is not expired in CPRS (Update CPRS/HDR with Exp. Date), Quit
. . I PATICN=-1 D Q ; NO ICN# - DO NOT send it to CPRS
. . . I 'NEWEXPDT S BADRXCNT(106)=$G(BADRXCNT(106))+1,^XTMP(NMSP,106,RXP,"HDR")=""
. . . I NEWEXPDT S BADRXCNT(107)=$G(BADRXCNT(107))+1,^XTMP(NMSP,107,RXP,"HDR")=""
. . 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)=""
. I 'NEWEXPDT Q ; Expiration Date was not recalculated, don't send to HDR
. I PATICN=-1 D Q ; NO ICN# - DO NOT send it to HDR
. . S BADRXCNT(108)=$G(BADRXCNT(108))+1
. . S ^XTMP(NMSP,108,RXP,"HDR")=""
. S BADRXCNT(8)=$G(BADRXCNT(8))+1,^XTMP(NMSP,8,RXP)=""
;
I EXPIRDT<CUTOFF,(PSOINACT'[(","_STATUS_",")) D ; Rx is past exp. date but is still on a non-Expired/DC'd status
. 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
. . I PATICN=-1 D Q ; NO ICN# - Send it to CPRS but not to HDR
. . . S BADRXCNT(109)=$G(BADRXCNT(109))+1
. . . S ^XTMP(NMSP,109,RXP,"HDR")=""
. . S BADRXCNT(9)=$G(BADRXCNT(9))+1,^XTMP(NMSP,9,RXP)=""
. I ORN D Q ; If CPRS was not updated, call HDR if there is an Order #
. . I PATICN=-1 D Q ; NO ICN# - DO NOT send it to HDR
. . . S BADRXCNT(110)=$G(BADRXCNT(110))+1
. . . S ^XTMP(NMSP,110,RXP,"HDR")=""
. . S BADRXCNT(10)=$G(BADRXCNT(10))+1,^XTMP(NMSP,10,RXP)=""
. I 'ORN D ; If no CPRS Order #, just report (no updates to CPRS/HDR)
. . I PATICN=-1 D Q ; NO ICN# - DO NOT send it to HDR
. . . S BADRXCNT(111)=$G(BADRXCNT(111))+1
. . . S ^XTMP(NMSP,111,RXP,"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
. . I PATICN=-1 D Q ; NO ICN# - DO NOT send it to HDR
. . . S BADRXCNT(112)=$G(BADRXCNT(112))+1
. . . S ^XTMP(NMSP,112,RXP,"HDR")=""
. . S BADRXCNT(12)=$G(BADRXCNT(12))+1,^XTMP(NMSP,12,RXP)=""
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^PSO283P1("RE-STARTED")
I '$D(^XTMP(NMSP,"STARTED")) D
. S ^XTMP(NMSP,"STARTED")=$$NOW^XLFDT() D LOG^PSO283P1("STARTED")
K ^XTMP(NMSP,"STOP"),^XTMP(NMSP,"STOPPED")
S ^XTMP(NMSP,0)=$$FMADD^XLFDT($$NOW^XLFDT(),730)_"^"_$$NOW^XLFDT()_"^PSO*7*283 - RX EXPIRATION DATE PROBLEM TALLY"
Q
PSO283PI ;BIR/MFR-EXPIRATION DATE PROBLEM TALLY ;05/03/07
+1 ;;7.0;OUTPATIENT PHARMACY;**283**;DEC 1997;Build 28
+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,Y,ACTION,EXPJOBDT,PSODUZ
+6 SET NMSP="PSO283PI"
+7 ;
+8 SET JOBSTS=$$JOBSTS^PSO283P1()
+9 ;
+10 WRITE !?5,"Expiration Date problem tally patch for Outpatient Pharmacy 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 $GET(^XTMP(NMSP,"LASTRX"))
WRITE " (Last Rx IEN: "_$GET(^XTMP(NMSP,"LASTRX"))_")"
+18 ;
+19 SET DIR(0)="SO^"
SET DIR("A")=""
+20 IF JOBSTS="N"
Begin DoDot:1
+21 SET DIR(0)=DIR(0)_"ST:START TALLY JOB;"
SET DIR("A")=DIR("A")_"(ST)Start,"
SET DIR("B")="START"
End DoDot:1
+22 IF JOBSTS="S"
Begin DoDot:1
+23 SET DIR(0)=DIR(0)_"RE:RESUME TALLY JOB;"
SET DIR("A")=DIR("A")_"(RE)Resume,"
End DoDot:1
+24 IF JOBSTS="R"
Begin DoDot:1
+25 SET DIR(0)=DIR(0)_"SP:STOP TALLY JOB;"
SET DIR("A")=DIR("A")_"(SP)Stop,"
End DoDot:1
+26 IF JOBSTS="C"
Begin DoDot:1
+27 SET DIR(0)=DIR(0)_"RR:RE-RUN TALLY JOB;"
SET DIR("A")=DIR("A")_"(RR)Re-run,"
End DoDot:1
+28 SET DIR(0)=DIR(0)_"VW:VIEW "_$SELECT(JOBSTS'="C":"PARTIAL ",1:"")_"TALLY JOB RESULTS;"
+29 SET DIR("A")=DIR("A")_"(VW)View,"
SET DIR("B")="VIEW"
+30 SET DIR(0)=DIR(0)_"QT:QUIT"
SET DIR("A")=DIR("A")_"(QT)Quit"
+31 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)
GOTO QUIT
+32 SET ACTION=Y
+33 ;
+34 IF ACTION="SP"
WRITE !!,"Stopping..."
Begin DoDot:1
+35 NEW TIME,UNABLE
+36 SET ^XTMP(NMSP,"STOP")=1
SET (TIME,UNABLE)=0
+37 FOR
IF $DATA(^XTMP(NMSP,"STOPPED"))
QUIT
Begin DoDot:2
+38 HANG 1
SET TIME=TIME+1
IF $DATA(^XTMP(NMSP,"COMPLETED"))!($$JOBSTS^PSO283P1()'="R")!(TIME>30)
SET UNABLE=1
End DoDot:2
IF UNABLE
QUIT
+39 WRITE $SELECT(UNABLE:"NOT OK (may no longer be running)",1:"OK")
+40 KILL ^XTMP(NMSP,"STOP")
End DoDot:1
GOTO QUIT
+41 ;
+42 IF ACTION="QT"
GOTO QUIT
+43 IF ACTION="VW"
DO DISPLAY^PSO283P1
GOTO QUIT
+44 IF ACTION="RR"
KILL ^XTMP(NMSP)
+45 ;
+46 DO JOB^PSO283P1()
+47 QUIT
+48 ;
PI ; Post-Install entry point
+1 NEW EXPJOBDT,NMSP
+2 SET NMSP="PSO283PI"
KILL ^XTMP(NMSP)
+3 DO LOG^PSO283P1("PATCH INSTALLATION")
+4 DO JOB^PSO283P1($$NOW^XLFDT())
+5 QUIT
+6 ;
EN ;
+1 NEW NMSP,PSOINST,CUTOFF,PSOACT,RXP,STOP,PSOINACT,PATIENT,COUNTER,RXP,PATICN,DRUG,STATUS
+2 NEW ISSUEDT,EXPIRDT,BADRXCNT,DAYSSUP,NUMREFS
+3 ;
+4 SET NMSP="PSO283PI"
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^PSO283P1("UNSUCCESSFUL (LOCKED)")
GOTO QUIT
+8 ;
+9 DO SETXTMP
+10 ;
+11 IF '$GET(DT)
SET DT=$$DT^XLFDT
+12 ;
+13 SET PSOINST=$PIECE($$SITE^VASITE(),"^",2)_" ("_+$$SITE^VASITE()_")"
+14 SET CUTOFF=$$FMADD^XLFDT(DT,-2)
+15 SET PSOINACT=",11,12,13,14,15,"
+16 SET RXP=+$GET(^XTMP(NMSP,0,"LASTRX"))
SET STOP=0
+17 FOR COUNTER=1:1
SET RXP=$ORDER(^PSRX(RXP))
IF 'RXP
QUIT
Begin DoDot:1
+18 IF '(COUNTER#100000)
SET DT=$$DT^XLFDT()
+19 SET PATIENT=$PIECE($GET(^PSRX(RXP,0)),"^",2)
+20 SET PATICN=$PIECE($$GETICN^MPIF001(PATIENT),"^")
+21 SET DRUG=$PIECE($GET(^PSRX(RXP,0)),"^",6)
+22 SET STATUS=$PIECE($GET(^PSRX(RXP,"STA")),"^")
+23 SET ISSUEDT=$PIECE($GET(^PSRX(RXP,0)),"^",13)
+24 SET DAYSSUP=$PIECE($GET(^PSRX(RXP,0)),"^",8)
+25 SET NUMREFS=$PIECE($GET(^PSRX(RXP,0)),"^",9)
+26 SET EXPIRDT=$PIECE($GET(^PSRX(RXP,2)),"^",6)
+27 SET BADRXCNT(14)=$GET(BADRXCNT(14))+1
+28 SET BADRXCNT("LASTRX")=RXP
+29 ;--- eliminate bad Rx's
+30 IF ('PATIENT!'DRUG)
SET BADRXCNT(13)=$GET(BADRXCNT(13))+1
QUIT
+31 IF '$DATA(^DPT(PATIENT))!('$DATA(^PSDRUG(DRUG)))
SET BADRXCNT(13)=$GET(BADRXCNT(13))+1
QUIT
+32 IF 'ISSUEDT
SET BADRXCNT(13)=$GET(BADRXCNT(13))+1
QUIT
+33 ;---
+34 DO SET
+35 ;---
+36 IF '(COUNTER#10000)
Begin DoDot:2
+37 MERGE ^XTMP(NMSP)=BADRXCNT
+38 IF $GET(^XTMP(NMSP,"STOP"))
SET STOP=1
End DoDot:2
End DoDot:1
IF STOP
QUIT
+39 ;
+40 IF STOP
DO STOP
GOTO QUIT
+41 ;
+42 MERGE ^XTMP(NMSP)=BADRXCNT
+43 SET ^XTMP(NMSP,"COMPLETED")=$$NOW^XLFDT()
+44 KILL ^XTMP(NMSP,"LASTRX")
+45 DO LOG^PSO283P1("COMPLETED")
+46 DO MAIL^PSO283P1
+47 ;
QUIT ;
+1 LOCK -^XTMP(NMSP)
+2 QUIT
+3 ;
STOP ;
+1 KILL ^XTMP(NMSP,"STOP")
+2 SET ^XTMP(NMSP,"STOPPED")=$$NOW^XLFDT()
+3 DO LOG^PSO283P1("STOPPED")
+4 DO MAIL^PSO283P1
+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 CALCEXP^PSO283P1
IF '$GET(EXPIRDT)
QUIT
+8 ; Expiration Date past Cutoff (will be exp. by auto exp. job), Quit
IF EXPIRDT>CUTOFF
Begin DoDot:2
+9 ; NO ICN# - DO NOT send it to HDR
IF PATICN=-1
Begin DoDot:3
+10 SET BADRXCNT(102)=$GET(BADRXCNT(102))+1
+11 SET ^XTMP(NMSP,102,RXP,"HDR")=""
End DoDot:3
QUIT
+12 SET BADRXCNT(2)=$GET(BADRXCNT(2))+1
SET ^XTMP(NMSP,2,RXP)=""
End DoDot:2
QUIT
+13 ; Rx is expired in CPRS (Update HDR with Exp. Date), Quit
IF ORN
Begin DoDot:2
+14 ; NO ICN# - DO NOT send it to HDR
IF PATICN=-1
Begin DoDot:3
+15 IF CPRSDC'[(","_CPRSTA_",")
Begin DoDot:4
+16 SET ^XTMP(NMSP,103,RXP,"HDR")=""
SET BADRXCNT(103)=$GET(BADRXCNT(103))+1
End DoDot:4
+17 IF CPRSDC[(","_CPRSTA_",")
Begin DoDot:4
+18 SET ^XTMP(NMSP,104,RXP,"HDR")=""
SET BADRXCNT(104)=$GET(BADRXCNT(104))+1
End DoDot:4
End DoDot:3
QUIT
+19 IF CPRSDC'[(","_CPRSTA_",")
Begin DoDot:3
+20 SET BADRXCNT(3)=$GET(BADRXCNT(3))+1
SET ^XTMP(NMSP,3,RXP)=""
End DoDot:3
QUIT
+21 SET BADRXCNT(4)=$GET(BADRXCNT(4))+1
SET ^XTMP(NMSP,4,RXP)=""
End DoDot:2
QUIT
+22 ; No CPRS Order # (Update HDR with Exp. Date)
IF 'ORN
Begin DoDot:2
+23 ; NO ICN# - DO NOT send it to HDR
IF PATICN=-1
Begin DoDot:3
+24 SET BADRXCNT(105)=$GET(BADRXCNT(105))+1
+25 SET ^XTMP(NMSP,105,RXP,"HDR")=""
End DoDot:3
QUIT
+26 SET BADRXCNT(5)=$GET(BADRXCNT(5))+1
SET ^XTMP(NMSP,5,RXP)=""
End DoDot:2
End DoDot:1
QUIT
+27 ;
+28 ; --- Rx is expired. Update CPRS and HDR if necessary
+29 IF STATUS=11
Begin DoDot:1
+30 SET ORN=$$CPRSNUM(RXP)
SET CPRSTA=$PIECE(ORN,"^",2)
SET ORN=+ORN
+31 SET NEWEXPDT=0
+32 ; Expiration Date is > 366, Recalculate new Date
IF $$FMDIFF^XLFDT(EXPIRDT,ISSUEDT,1)>366
Begin DoDot:2
+33 SET NEWEXPDT=1
DO CALCEXP^PSO283P1
End DoDot:2
+34 ; Rx is not expired in CPRS (Update CPRS/HDR with Exp. Date), Quit
IF ORN
IF CPRSDC'[(","_CPRSTA_",")
Begin DoDot:2
+35 ; NO ICN# - DO NOT send it to CPRS
IF PATICN=-1
Begin DoDot:3
+36 IF 'NEWEXPDT
SET BADRXCNT(106)=$GET(BADRXCNT(106))+1
SET ^XTMP(NMSP,106,RXP,"HDR")=""
+37 IF NEWEXPDT
SET BADRXCNT(107)=$GET(BADRXCNT(107))+1
SET ^XTMP(NMSP,107,RXP,"HDR")=""
End DoDot:3
QUIT
+38 IF 'NEWEXPDT
SET BADRXCNT(6)=$GET(BADRXCNT(6))+1
SET ^XTMP(NMSP,6,RXP)=""
+39 IF NEWEXPDT
SET BADRXCNT(7)=$GET(BADRXCNT(7))+1
SET ^XTMP(NMSP,7,RXP)=""
End DoDot:2
+40 ; Expiration Date was not recalculated, don't send to HDR
IF 'NEWEXPDT
QUIT
+41 ; NO ICN# - DO NOT send it to HDR
IF PATICN=-1
Begin DoDot:2
+42 SET BADRXCNT(108)=$GET(BADRXCNT(108))+1
+43 SET ^XTMP(NMSP,108,RXP,"HDR")=""
End DoDot:2
QUIT
+44 SET BADRXCNT(8)=$GET(BADRXCNT(8))+1
SET ^XTMP(NMSP,8,RXP)=""
End DoDot:1
QUIT
+45 ;
+46 ; Rx is past exp. date but is still on a non-Expired/DC'd status
IF EXPIRDT<CUTOFF
IF (PSOINACT'[(","_STATUS_","))
Begin DoDot:1
+47 SET ORN=$$CPRSNUM(RXP)
SET CPRSTA=$PIECE(ORN,"^",2)
SET ORN=+ORN
+48 ; Update CPRS if necessary, this will also call HDR
IF ORN
IF CPRSDC'[(","_CPRSTA_",")
Begin DoDot:2
+49 ; NO ICN# - Send it to CPRS but not to HDR
IF PATICN=-1
Begin DoDot:3
+50 SET BADRXCNT(109)=$GET(BADRXCNT(109))+1
+51 SET ^XTMP(NMSP,109,RXP,"HDR")=""
End DoDot:3
QUIT
+52 SET BADRXCNT(9)=$GET(BADRXCNT(9))+1
SET ^XTMP(NMSP,9,RXP)=""
End DoDot:2
QUIT
+53 ; If CPRS was not updated, call HDR if there is an Order #
IF ORN
Begin DoDot:2
+54 ; NO ICN# - DO NOT send it to HDR
IF PATICN=-1
Begin DoDot:3
+55 SET BADRXCNT(110)=$GET(BADRXCNT(110))+1
+56 SET ^XTMP(NMSP,110,RXP,"HDR")=""
End DoDot:3
QUIT
+57 SET BADRXCNT(10)=$GET(BADRXCNT(10))+1
SET ^XTMP(NMSP,10,RXP)=""
End DoDot:2
QUIT
+58 ; If no CPRS Order #, just report (no updates to CPRS/HDR)
IF 'ORN
Begin DoDot:2
+59 ; NO ICN# - DO NOT send it to HDR
IF PATICN=-1
Begin DoDot:3
+60 SET BADRXCNT(111)=$GET(BADRXCNT(111))+1
+61 SET ^XTMP(NMSP,111,RXP,"HDR")=""
End DoDot:3
QUIT
+62 SET BADRXCNT(11)=$GET(BADRXCNT(11))+1
+63 SET ^XTMP(NMSP,11,RXP)=""
End DoDot:2
End DoDot:1
+64 ;
+65 IF STATUS=13
Begin DoDot:1
+66 SET ORN=+$$CPRSNUM(RXP)
+67 IF 'ORN
Begin DoDot:2
+68 ; NO ICN# - DO NOT send it to HDR
IF PATICN=-1
Begin DoDot:3
+69 SET BADRXCNT(112)=$GET(BADRXCNT(112))+1
+70 SET ^XTMP(NMSP,112,RXP,"HDR")=""
End DoDot:3
QUIT
+71 SET BADRXCNT(12)=$GET(BADRXCNT(12))+1
SET ^XTMP(NMSP,12,RXP)=""
End DoDot:2
End DoDot:1
QUIT
+72 QUIT
+73 ;
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^PSO283P1("RE-STARTED")
End DoDot:1
+3 IF '$DATA(^XTMP(NMSP,"STARTED"))
Begin DoDot:1
+4 SET ^XTMP(NMSP,"STARTED")=$$NOW^XLFDT()
DO LOG^PSO283P1("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*283 - RX EXPIRATION DATE PROBLEM TALLY"
+7 QUIT
