PSOELPST ;BIR/RTR-Status update ;11/27/01
;;7.0;OUTPATIENT PHARMACY;**86**;DEC 1997
;External reference to STATUS^ORQOR2 supported by DBIA 3458
;External reference to ^OR(100 supported by DBIA 3463
;CPRS/Outpatient status update
;PSOCPRS = CPRS number (Placer)
;PSORXNUM = Outpatient number (52 ien)
I '$G(XPDENV) Q
N PSOPACRF
S DIC=9.4,DIC(0)="Z",X="OUTPATIENT PHARMACY" D ^DIC K DIC I +Y'>0 W !!,"A problem was found when trying to identify a valid Outpatient Pharmacy",!,"package reference from the PACKAGE (#9.4) file." D S XPDQUIT=2 Q
.W !,"This Patch cannot be installed until this problem is resolved.",!
.K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
S PSOPACRF=+Y
W !,"This patch queues a job to find Outpatient Pharmacy orders that are expired or",!,"Discontinued, but are Active in CPRS. This patch will update the order in CPRS",!,"with the appropriate status."
W ! K ZTDTH S ZTRTN="EN^PSOELPST",ZTDESC="Pharmacy/CPRS status clean up",ZTIO="",ZTSAVE("PSOPACRF")="" D ^%ZTLOAD I '$G(ZTSK) D S XPDQUIT=2
.W !!,"Since this job was not queued, the patch will not be installed.",! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
Q
EN ;
N PSOCPRS,PSORXNUM,PSOXCOM,PSOXDT,PSOIJ,PSOJJ,PSOREAS,PSOACRL,PSOPHR,PSOALC,PSOADT,PSONAT,PSOCOMM,PSOZDUZ,PSOELSTA,PSOELSTP,PSOETEXT,PSOECT,PSOCSTAT
I '$G(DT) S DT=$$DT^XLFDT
D NOW^%DTC S PSOELSTA=%
S PSOECT=0
S PSOCPRS="" F S PSOCPRS=$O(^PSRX("APL",PSOCPRS)) Q:PSOCPRS="" S PSORXNUM="" F S PSORXNUM=$O(^PSRX("APL",PSOCPRS,PSORXNUM)) Q:PSORXNUM="" D
.I PSOCPRS'=$P($G(^PSRX(PSORXNUM,"OR1")),"^",2) Q
.I '$D(^PSRX(PSORXNUM,0)) Q
.I +$$STATUS^ORQOR2(PSOCPRS)'=6 Q
.I PSORXNUM'=$P($G(^OR(100,PSOCPRS,4)),"^") Q
.I PSOPACRF'=$P($G(^OR(100,PSOCPRS,0)),"^",14) Q
.S PSOCSTAT=$P($G(^PSRX(PSORXNUM,"STA")),"^")
.I PSOCSTAT=11 D Q
..I $P(^PSRX(PSORXNUM,0),"^",19)=2 S $P(^(0),"^",19)=1
..S PSOXCOM="Prescription past expiration date" D EN^PSOHLSN1(PSORXNUM,"SC","ZE",PSOXCOM) S PSOECT=PSOECT+1
..S PSOXDT=$S($P($G(^PSRX(PSORXNUM,2)),"^",6):$E($P($G(^(2)),"^",6),1,7),1:DT)_".2200"
..I $D(^OR(100,PSOCPRS,3)) S $P(^(3),"^")=PSOXDT
.I PSOCSTAT=12!(PSOCSTAT=14)!(PSOCSTAT=15) D
..S (PSOIJ,PSOJJ,PSOPHR,PSOADT)=0 F S PSOIJ=$O(^PSRX(PSORXNUM,"A",PSOIJ)) Q:'PSOIJ S PSOREAS=$P($G(^(PSOIJ,0)),"^",2) I PSOREAS="C"!(PSOREAS="L") S PSOJJ=PSOIJ
..I PSOJJ S PSOACRL=$G(^PSRX(PSORXNUM,"A",PSOJJ,0)) D
...S PSOPHR=$P(PSOACRL,"^",3),PSOALC=$P(PSOACRL,"^",5),PSOADT=$P(PSOACRL,"^"),(PSONAT,PSOCOMM)=""
...I PSOALC["Renewed" S PSOCOMM="Renewed by Pharmacy"
...I PSOALC["Auto Discontinued" S PSOPHR="",PSONAT="A",PSOCOMM=$E($P(PSOALC,".",2),2,99) S:PSOCOMM="" PSOCOMM=PSOALC
...I PSOALC["Discontinued During" S PSOCOMM="Discontinued by Pharmacy"
..I 'PSOJJ S PSOCOMM="Discontinued by Pharmacy",PSONAT=""
..S PSOZDUZ=$G(DUZ) S:$G(PSOPHR) DUZ=PSOPHR D EN^PSOHLSN1(PSORXNUM,"OD",$S(PSOCSTAT=15:"RP",1:""),PSOCOMM,PSONAT) S PSOECT=PSOECT+1 S DUZ=PSOZDUZ
..I '$G(PSOADT) S PSOADT=DT_".2200"
..I $D(^OR(100,PSOCPRS,6)) S $P(^(6),"^",3)=$E(PSOADT,1,12)
..I $D(^OR(100,PSOCPRS,3)) S $P(^(3),"^")=$E(PSOADT,1,12)
MAIL ;Send mail message upon job completion
K PSOPACRF
I $G(DUZ) D
.S XMDUZ="Patch PSO*7*86 Patch Install",XMSUB="Outpatient/CPRS Status clean-up",XMY(DUZ)=""
.D NOW^%DTC S PSOELSTP=%
.S PSOETEXT(1)="The tasked job for patch PSO*7*86 is complete."
.S PSOETEXT(2)="The total number of mismatched statuses found were "_+$G(PSOECT)_"."
.S Y=$G(PSOELSTA) D DD^%DT S PSOELSTA=$G(Y)
.S Y=$G(PSOELSTP) D DD^%DT S PSOELSTP=$G(Y)
.S PSOETEXT(3)="The job started on "_$G(PSOELSTA)_"."
.S PSOETEXT(4)="The job ended on "_$G(PSOELSTP)_"."
.S XMTEXT="PSOETEXT(" N DIFROM D ^XMD K Y,XMDUZ,XMTEXT,XMSUB
S:$D(ZTQUEUED) ZTREQ="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOELPST 3804 printed Dec 13, 2024@02:27:28 Page 2
PSOELPST ;BIR/RTR-Status update ;11/27/01
+1 ;;7.0;OUTPATIENT PHARMACY;**86**;DEC 1997
+2 ;External reference to STATUS^ORQOR2 supported by DBIA 3458
+3 ;External reference to ^OR(100 supported by DBIA 3463
+4 ;CPRS/Outpatient status update
+5 ;PSOCPRS = CPRS number (Placer)
+6 ;PSORXNUM = Outpatient number (52 ien)
+7 IF '$GET(XPDENV)
QUIT
+8 NEW PSOPACRF
+9 SET DIC=9.4
SET DIC(0)="Z"
SET X="OUTPATIENT PHARMACY"
DO ^DIC
KILL DIC
IF +Y'>0
WRITE !!,"A problem was found when trying to identify a valid Outpatient Pharmacy",!,"package reference from the PACKAGE (#9.4) file."
Begin DoDot:1
+10 WRITE !,"This Patch cannot be installed until this problem is resolved.",!
+11 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
End DoDot:1
SET XPDQUIT=2
QUIT
+12 SET PSOPACRF=+Y
+13 WRITE !,"This patch queues a job to find Outpatient Pharmacy orders that are expired or",!,"Discontinued, but are Active in CPRS. This patch will update the order in CPRS",!,"with the appropriate status."
+14 WRITE !
KILL ZTDTH
SET ZTRTN="EN^PSOELPST"
SET ZTDESC="Pharmacy/CPRS status clean up"
SET ZTIO=""
SET ZTSAVE("PSOPACRF")=""
DO ^%ZTLOAD
IF '$GET(ZTSK)
Begin DoDot:1
+15 WRITE !!,"Since this job was not queued, the patch will not be installed.",!
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
End DoDot:1
SET XPDQUIT=2
+16 QUIT
EN ;
+1 NEW PSOCPRS,PSORXNUM,PSOXCOM,PSOXDT,PSOIJ,PSOJJ,PSOREAS,PSOACRL,PSOPHR,PSOALC,PSOADT,PSONAT,PSOCOMM,PSOZDUZ,PSOELSTA,PSOELSTP,PSOETEXT,PSOECT,PSOCSTAT
+2 IF '$GET(DT)
SET DT=$$DT^XLFDT
+3 DO NOW^%DTC
SET PSOELSTA=%
+4 SET PSOECT=0
+5 SET PSOCPRS=""
FOR
SET PSOCPRS=$ORDER(^PSRX("APL",PSOCPRS))
if PSOCPRS=""
QUIT
SET PSORXNUM=""
FOR
SET PSORXNUM=$ORDER(^PSRX("APL",PSOCPRS,PSORXNUM))
if PSORXNUM=""
QUIT
Begin DoDot:1
+6 IF PSOCPRS'=$PIECE($GET(^PSRX(PSORXNUM,"OR1")),"^",2)
QUIT
+7 IF '$DATA(^PSRX(PSORXNUM,0))
QUIT
+8 IF +$$STATUS^ORQOR2(PSOCPRS)'=6
QUIT
+9 IF PSORXNUM'=$PIECE($GET(^OR(100,PSOCPRS,4)),"^")
QUIT
+10 IF PSOPACRF'=$PIECE($GET(^OR(100,PSOCPRS,0)),"^",14)
QUIT
+11 SET PSOCSTAT=$PIECE($GET(^PSRX(PSORXNUM,"STA")),"^")
+12 IF PSOCSTAT=11
Begin DoDot:2
+13 IF $PIECE(^PSRX(PSORXNUM,0),"^",19)=2
SET $PIECE(^(0),"^",19)=1
+14 SET PSOXCOM="Prescription past expiration date"
DO EN^PSOHLSN1(PSORXNUM,"SC","ZE",PSOXCOM)
SET PSOECT=PSOECT+1
+15 SET PSOXDT=$SELECT($PIECE($GET(^PSRX(PSORXNUM,2)),"^",6):$EXTRACT($PIECE($GET(^(2)),"^",6),1,7),1:DT)_".2200"
+16 IF $DATA(^OR(100,PSOCPRS,3))
SET $PIECE(^(3),"^")=PSOXDT
End DoDot:2
QUIT
+17 IF PSOCSTAT=12!(PSOCSTAT=14)!(PSOCSTAT=15)
Begin DoDot:2
+18 SET (PSOIJ,PSOJJ,PSOPHR,PSOADT)=0
FOR
SET PSOIJ=$ORDER(^PSRX(PSORXNUM,"A",PSOIJ))
if 'PSOIJ
QUIT
SET PSOREAS=$PIECE($GET(^(PSOIJ,0)),"^",2)
IF PSOREAS="C"!(PSOREAS="L")
SET PSOJJ=PSOIJ
+19 IF PSOJJ
SET PSOACRL=$GET(^PSRX(PSORXNUM,"A",PSOJJ,0))
Begin DoDot:3
+20 SET PSOPHR=$PIECE(PSOACRL,"^",3)
SET PSOALC=$PIECE(PSOACRL,"^",5)
SET PSOADT=$PIECE(PSOACRL,"^")
SET (PSONAT,PSOCOMM)=""
+21 IF PSOALC["Renewed"
SET PSOCOMM="Renewed by Pharmacy"
+22 IF PSOALC["Auto Discontinued"
SET PSOPHR=""
SET PSONAT="A"
SET PSOCOMM=$EXTRACT($PIECE(PSOALC,".",2),2,99)
if PSOCOMM=""
SET PSOCOMM=PSOALC
+23 IF PSOALC["Discontinued During"
SET PSOCOMM="Discontinued by Pharmacy"
End DoDot:3
+24 IF 'PSOJJ
SET PSOCOMM="Discontinued by Pharmacy"
SET PSONAT=""
+25 SET PSOZDUZ=$GET(DUZ)
if $GET(PSOPHR)
SET DUZ=PSOPHR
DO EN^PSOHLSN1(PSORXNUM,"OD",$SELECT(PSOCSTAT=15:"RP",1:""),PSOCOMM,PSONAT)
SET PSOECT=PSOECT+1
SET DUZ=PSOZDUZ
+26 IF '$GET(PSOADT)
SET PSOADT=DT_".2200"
+27 IF $DATA(^OR(100,PSOCPRS,6))
SET $PIECE(^(6),"^",3)=$EXTRACT(PSOADT,1,12)
+28 IF $DATA(^OR(100,PSOCPRS,3))
SET $PIECE(^(3),"^")=$EXTRACT(PSOADT,1,12)
End DoDot:2
End DoDot:1
MAIL ;Send mail message upon job completion
+1 KILL PSOPACRF
+2 IF $GET(DUZ)
Begin DoDot:1
+3 SET XMDUZ="Patch PSO*7*86 Patch Install"
SET XMSUB="Outpatient/CPRS Status clean-up"
SET XMY(DUZ)=""
+4 DO NOW^%DTC
SET PSOELSTP=%
+5 SET PSOETEXT(1)="The tasked job for patch PSO*7*86 is complete."
+6 SET PSOETEXT(2)="The total number of mismatched statuses found were "_+$GET(PSOECT)_"."
+7 SET Y=$GET(PSOELSTA)
DO DD^%DT
SET PSOELSTA=$GET(Y)
+8 SET Y=$GET(PSOELSTP)
DO DD^%DT
SET PSOELSTP=$GET(Y)
+9 SET PSOETEXT(3)="The job started on "_$GET(PSOELSTA)_"."
+10 SET PSOETEXT(4)="The job ended on "_$GET(PSOELSTP)_"."
+11 SET XMTEXT="PSOETEXT("
NEW DIFROM
DO ^XMD
KILL Y,XMDUZ,XMTEXT,XMSUB
End DoDot:1
+12 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+13 QUIT
