PSOELPS2 ;BIR/EJW-CPRS and Outpatient Pharmacy Status Update ;12/04/02
;;7.0;OUTPATIENT PHARMACY;**119,268**;DEC 1997;Build 9
;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)
N PSOPACRF
D GETPACRF
I '$D(PSOPACRF) Q
D BMES^XPDUTL("This post-install job searches for Outpatient Pharmacy orders")
D MES^XPDUTL("that are deleted but are Active in CPRS. If any are found")
D MES^XPDUTL("the order in CPRS will be updated with the appropriate status.")
D BMES^XPDUTL("The job also looks for Outpatient Pharmacy orders that are marked")
D MES^XPDUTL("as DC'd by provider and if they really were deleted instead")
D MES^XPDUTL("of discontinued, the CPRS order will be updated with the")
D MES^XPDUTL("correct Stop Date.")
D BMES^XPDUTL("This post-install also attempts to clean up a bad node in the")
D MES^XPDUTL("PRESCRIPTION file (#52) caused if an up-arrow (^) was entered for")
D MES^XPDUTL("the LOT# when editing a prescription.")
D GETDATE
S ZTRTN="EN^PSOELPS2",ZTDESC="Pharmacy/CPRS status clean up",ZTIO="",ZTSAVE("PSOPACRF")="" D ^%ZTLOAD K ZTDTH,ZTRTN,ZTIO,ZTDESC
W:$D(ZTSK)&('$D(ZTQUEUED)) !!,"Task Queued !",!
Q
EN ;
L +^XTMP("PSOELPS2"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T S:$D(ZTQUEUED) ZTREQ="@" Q
N PSOCPRS,PSORXNUM,PSOXCOM,PSOXDT,PSOIJ,PSOJJ,PSOREAS,PSOACRL,PSOPHR,PSOALC,PSOADT,PSONAT,PSOCOMM,PSOZDUZ,PSOSTART,PSOEND,PSOETEXT,PSOECT,PSOCSTAT,PSOSTA
I '$D(PSOPACRF) D GETPACRF I '$D(PSOPACRF) Q
I '$G(DT) S DT=$$DT^XLFDT
D NOW^%DTC S PSOSTART=%
S PSOECT=0,PSORX2=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
.D CHKARROW ; SEE IF AN EXTRA UP-ARROW IN ^PSRX(PSORXNUM,2) NODE
.S PSOSTA=+$$STATUS^ORQOR2(PSOCPRS) I PSOSTA'=6,PSOSTA'=1 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 PSOSTA=6,PSOCSTAT=13 D ; MARKED AS ACTIVE IN CPRS, DELETED IN O/P PHARMACY
..D GETDEL
..I 'PSOJJ Q
..D UPDCPRS
.I PSOSTA=1,PSOCSTAT=14 D ; MARKED AS 'DISCONTINUED BY PROVIDER' IN CPRS - CHECK FOR PREVIOUSLY DELETED IN O/P PHARMACY
..D GETDEL
..I 'PSOJJ Q
..D ACT
..D UPDCPRS
..S $P(^PSRX(PSORXNUM,"STA"),"^",1)=13
MAIL ;Send MailMan message upon job completion
K PSOPACRF
I $G(DUZ) D
.S XMDUZ="Patch PSO*7*119 Post-Install",XMSUB="Outpatient/CPRS Status clean-up",XMY(DUZ)=""
.D NOW^%DTC S PSOEND=%
.S PSOETEXT(1)="The clean-up job for patch PSO*7*119 is complete."
.S PSOETEXT(2)="The total number of mismatched statuses found were "_+$G(PSOECT)_"."
.S PSOETEXT(3)="The total number of missing divisions were "_PSORX2_"."
.S Y=$G(PSOSTART) D DD^%DT S PSOSTART=$G(Y)
.S Y=$G(PSOEND) D DD^%DT S PSOEND=$G(Y)
.S PSOETEXT(4)="The job started on "_$G(PSOSTART)_"."
.S PSOETEXT(5)="The job ended on "_$G(PSOEND)_"."
.S XMTEXT="PSOETEXT(" N DIFROM D ^XMD K Y,XMDUZ,XMTEXT,XMSUB
L -^XTMP("PSOELPS2")
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
GETDEL ;
S PSOCOMM=""
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="D" I $P($G(^PSRX(PSORXNUM,"A",PSOIJ,0)),"^",4)=0 S PSOJJ=PSOIJ
I 'PSOJJ Q
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["DELETED" S PSOCOMM=PSOALC
Q
;
UPDCPRS ; UPDATE CPRS ENTRY WITH CORRECT STATUS AND DATE
S PSOZDUZ=$G(DUZ) S:$G(PSOPHR) DUZ=PSOPHR D EN^PSOHLSN1(PSORXNUM,"OC","",PSOCOMM,PSONAT) S PSOECT=PSOECT+1 S DUZ=PSOZDUZ
I '$G(PSOADT) S PSOADT=DT_".2200"
I '$D(^XTMP("PSOELPS2")) S X1=DT,X2=+30 D C^%DTC S ^XTMP("PSOELPS2",0)=$G(X)_"^"_DT
I $D(^OR(100,PSOCPRS,6)) S ^XTMP("PSOELPS2",$J,PSOCPRS,6)=^(6),$P(^OR(100,PSOCPRS,6),"^",3)=$E(PSOADT,1,12)
I $D(^OR(100,PSOCPRS,3)) S ^XTMP("PSOELPS2",$J,PSOCPRS,3)=^(3),$P(^OR(100,PSOCPRS,3),"^")=$E(PSOADT,1,12)
Q
;
ACT ; SET ENTRY IN ACTIVITY LOG
N IR,J
S IR=0 F J=0:0 S J=$O(^PSRX(PSORXNUM,"A",J)) Q:'J S IR=J
S IR=IR+1,^PSRX(PSORXNUM,"A",0)="^52.3DA^"_IR_"^"_IR
D NOW^%DTC S ^PSRX(PSORXNUM,"A",IR,0)=%_"^"_"E^"_$G(DUZ)_"^0^Dc'd by mistake, resetting back to deleted"
Q
;
CHKARROW ;
N RX2
S RX2=$G(^PSRX(PSORXNUM,2)) I RX2="" Q
I $P(RX2,"^",9)="" D
.I $P(RX2,"^",5)'?7N,$P(RX2,"^",6)?7N,$P(RX2,"^",7)?7N D
..S ^XTMP("PSOELPS2",$J,"RX2",PSORXNUM)=RX2
..S RX2=$P(RX2,"^",1,3)_"^"_$P(RX2,"^",5,99)
..S PSORX2=PSORX2+1
..S ^PSRX(PSORXNUM,2)=RX2
Q
;
GETPACRF ;
S DIC=9.4,DIC(0)="Z",X="OUTPATIENT PHARMACY" D ^DIC K DIC
I +Y'>0 D Q
.D BMES^XPDUTL("A problem was found when trying to identify a valid Outpatient Pharmacy")
.D BMES^XPDUTL("package reference from the PACKAGE (#9.4) file.")
.D BMES^XPDUTL("This post-install job cannot be run until this problem is resolved.")
.K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
S PSOPACRF=+Y
Q
;
GETDATE ; GET DATE/TIME OF WHEN BACKGROUND JOB SHOULD BE RUN
S ZTDTH=""
S NOW=0
D NOW^%DTC S (Y,TODAY)=% D DD^%DT
D BMES^XPDUTL("At the following prompt, enter a starting date@time or enter NOW to")
D MES^XPDUTL("queue the job immediately.")
D MES^XPDUTL("If this prompting is during patch installation, you will not see what you type.")
W ! K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Queue clean-up Job to run Date@Time: "
D ^%DT K %DT I $D(DTOUT)!(Y<0) D MES^XPDUTL("Task will be queued to run NOW") S ZTDTH=$H,NOW=1
I 'NOW,Y>0 D
.S SAVEY=Y
.D DD^%DT
.S X=Y
.S Y=SAVEY
ASK D BMES^XPDUTL("Task will be queued to run "_$S(NOW:"NOW",1:X)_". Is that correct? :")
R XX:300 S:'$T XX="Y" I $E(XX)'="Y",$E(XX)'="y",$E(XX)'="N",$E(XX)'="n" D BMES^XPDUTL(" Enter Y or N") G ASK
I $E(XX)'="Y",$E(XX)'="y" G GETDATE
I Y>0,ZTDTH="" S ZTDTH=Y
I ZTDTH="" S ZTDTH=$H
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOELPS2 6152 printed Sep 23, 2025@20:03:45 Page 2
PSOELPS2 ;BIR/EJW-CPRS and Outpatient Pharmacy Status Update ;12/04/02
+1 ;;7.0;OUTPATIENT PHARMACY;**119,268**;DEC 1997;Build 9
+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 NEW PSOPACRF
+8 DO GETPACRF
+9 IF '$DATA(PSOPACRF)
QUIT
+10 DO BMES^XPDUTL("This post-install job searches for Outpatient Pharmacy orders")
+11 DO MES^XPDUTL("that are deleted but are Active in CPRS. If any are found")
+12 DO MES^XPDUTL("the order in CPRS will be updated with the appropriate status.")
+13 DO BMES^XPDUTL("The job also looks for Outpatient Pharmacy orders that are marked")
+14 DO MES^XPDUTL("as DC'd by provider and if they really were deleted instead")
+15 DO MES^XPDUTL("of discontinued, the CPRS order will be updated with the")
+16 DO MES^XPDUTL("correct Stop Date.")
+17 DO BMES^XPDUTL("This post-install also attempts to clean up a bad node in the")
+18 DO MES^XPDUTL("PRESCRIPTION file (#52) caused if an up-arrow (^) was entered for")
+19 DO MES^XPDUTL("the LOT# when editing a prescription.")
+20 DO GETDATE
+21 SET ZTRTN="EN^PSOELPS2"
SET ZTDESC="Pharmacy/CPRS status clean up"
SET ZTIO=""
SET ZTSAVE("PSOPACRF")=""
DO ^%ZTLOAD
KILL ZTDTH,ZTRTN,ZTIO,ZTDESC
+22 if $DATA(ZTSK)&('$DATA(ZTQUEUED))
WRITE !!,"Task Queued !",!
+23 QUIT
EN ;
+1 LOCK +^XTMP("PSOELPS2"):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+2 NEW PSOCPRS,PSORXNUM,PSOXCOM,PSOXDT,PSOIJ,PSOJJ,PSOREAS,PSOACRL,PSOPHR,PSOALC,PSOADT,PSONAT,PSOCOMM,PSOZDUZ,PSOSTART,PSOEND,PSOETEXT,PSOECT,PSOCSTAT,PSOSTA
+3 IF '$DATA(PSOPACRF)
DO GETPACRF
IF '$DATA(PSOPACRF)
QUIT
+4 IF '$GET(DT)
SET DT=$$DT^XLFDT
+5 DO NOW^%DTC
SET PSOSTART=%
+6 SET PSOECT=0
SET PSORX2=0
+7 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
+8 IF PSOCPRS'=$PIECE($GET(^PSRX(PSORXNUM,"OR1")),"^",2)
QUIT
+9 IF '$DATA(^PSRX(PSORXNUM,0))
QUIT
+10 ; SEE IF AN EXTRA UP-ARROW IN ^PSRX(PSORXNUM,2) NODE
DO CHKARROW
+11 SET PSOSTA=+$$STATUS^ORQOR2(PSOCPRS)
IF PSOSTA'=6
IF PSOSTA'=1
QUIT
+12 IF PSORXNUM'=$PIECE($GET(^OR(100,PSOCPRS,4)),"^")
QUIT
+13 IF PSOPACRF'=$PIECE($GET(^OR(100,PSOCPRS,0)),"^",14)
QUIT
+14 SET PSOCSTAT=$PIECE($GET(^PSRX(PSORXNUM,"STA")),"^")
+15 ; MARKED AS ACTIVE IN CPRS, DELETED IN O/P PHARMACY
IF PSOSTA=6
IF PSOCSTAT=13
Begin DoDot:2
+16 DO GETDEL
+17 IF 'PSOJJ
QUIT
+18 DO UPDCPRS
End DoDot:2
+19 ; MARKED AS 'DISCONTINUED BY PROVIDER' IN CPRS - CHECK FOR PREVIOUSLY DELETED IN O/P PHARMACY
IF PSOSTA=1
IF PSOCSTAT=14
Begin DoDot:2
+20 DO GETDEL
+21 IF 'PSOJJ
QUIT
+22 DO ACT
+23 DO UPDCPRS
+24 SET $PIECE(^PSRX(PSORXNUM,"STA"),"^",1)=13
End DoDot:2
End DoDot:1
MAIL ;Send MailMan message upon job completion
+1 KILL PSOPACRF
+2 IF $GET(DUZ)
Begin DoDot:1
+3 SET XMDUZ="Patch PSO*7*119 Post-Install"
SET XMSUB="Outpatient/CPRS Status clean-up"
SET XMY(DUZ)=""
+4 DO NOW^%DTC
SET PSOEND=%
+5 SET PSOETEXT(1)="The clean-up job for patch PSO*7*119 is complete."
+6 SET PSOETEXT(2)="The total number of mismatched statuses found were "_+$GET(PSOECT)_"."
+7 SET PSOETEXT(3)="The total number of missing divisions were "_PSORX2_"."
+8 SET Y=$GET(PSOSTART)
DO DD^%DT
SET PSOSTART=$GET(Y)
+9 SET Y=$GET(PSOEND)
DO DD^%DT
SET PSOEND=$GET(Y)
+10 SET PSOETEXT(4)="The job started on "_$GET(PSOSTART)_"."
+11 SET PSOETEXT(5)="The job ended on "_$GET(PSOEND)_"."
+12 SET XMTEXT="PSOETEXT("
NEW DIFROM
DO ^XMD
KILL Y,XMDUZ,XMTEXT,XMSUB
End DoDot:1
+13 LOCK -^XTMP("PSOELPS2")
+14 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+15 QUIT
+16 ;
GETDEL ;
+1 SET PSOCOMM=""
+2 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="D"
IF $PIECE($GET(^PSRX(PSORXNUM,"A",PSOIJ,0)),"^",4)=0
SET PSOJJ=PSOIJ
+3 IF 'PSOJJ
QUIT
+4 SET PSOACRL=$GET(^PSRX(PSORXNUM,"A",PSOJJ,0))
Begin DoDot:1
+5 SET PSOPHR=$PIECE(PSOACRL,"^",3)
SET PSOALC=$PIECE(PSOACRL,"^",5)
SET PSOADT=$PIECE(PSOACRL,"^")
SET (PSONAT,PSOCOMM)=""
+6 IF PSOALC["DELETED"
SET PSOCOMM=PSOALC
End DoDot:1
+7 QUIT
+8 ;
UPDCPRS ; UPDATE CPRS ENTRY WITH CORRECT STATUS AND DATE
+1 SET PSOZDUZ=$GET(DUZ)
if $GET(PSOPHR)
SET DUZ=PSOPHR
DO EN^PSOHLSN1(PSORXNUM,"OC","",PSOCOMM,PSONAT)
SET PSOECT=PSOECT+1
SET DUZ=PSOZDUZ
+2 IF '$GET(PSOADT)
SET PSOADT=DT_".2200"
+3 IF '$DATA(^XTMP("PSOELPS2"))
SET X1=DT
SET X2=+30
DO C^%DTC
SET ^XTMP("PSOELPS2",0)=$GET(X)_"^"_DT
+4 IF $DATA(^OR(100,PSOCPRS,6))
SET ^XTMP("PSOELPS2",$JOB,PSOCPRS,6)=^(6)
SET $PIECE(^OR(100,PSOCPRS,6),"^",3)=$EXTRACT(PSOADT,1,12)
+5 IF $DATA(^OR(100,PSOCPRS,3))
SET ^XTMP("PSOELPS2",$JOB,PSOCPRS,3)=^(3)
SET $PIECE(^OR(100,PSOCPRS,3),"^")=$EXTRACT(PSOADT,1,12)
+6 QUIT
+7 ;
ACT ; SET ENTRY IN ACTIVITY LOG
+1 NEW IR,J
+2 SET IR=0
FOR J=0:0
SET J=$ORDER(^PSRX(PSORXNUM,"A",J))
if 'J
QUIT
SET IR=J
+3 SET IR=IR+1
SET ^PSRX(PSORXNUM,"A",0)="^52.3DA^"_IR_"^"_IR
+4 DO NOW^%DTC
SET ^PSRX(PSORXNUM,"A",IR,0)=%_"^"_"E^"_$GET(DUZ)_"^0^Dc'd by mistake, resetting back to deleted"
+5 QUIT
+6 ;
CHKARROW ;
+1 NEW RX2
+2 SET RX2=$GET(^PSRX(PSORXNUM,2))
IF RX2=""
QUIT
+3 IF $PIECE(RX2,"^",9)=""
Begin DoDot:1
+4 IF $PIECE(RX2,"^",5)'?7N
IF $PIECE(RX2,"^",6)?7N
IF $PIECE(RX2,"^",7)?7N
Begin DoDot:2
+5 SET ^XTMP("PSOELPS2",$JOB,"RX2",PSORXNUM)=RX2
+6 SET RX2=$PIECE(RX2,"^",1,3)_"^"_$PIECE(RX2,"^",5,99)
+7 SET PSORX2=PSORX2+1
+8 SET ^PSRX(PSORXNUM,2)=RX2
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
GETPACRF ;
+1 SET DIC=9.4
SET DIC(0)="Z"
SET X="OUTPATIENT PHARMACY"
DO ^DIC
KILL DIC
+2 IF +Y'>0
Begin DoDot:1
+3 DO BMES^XPDUTL("A problem was found when trying to identify a valid Outpatient Pharmacy")
+4 DO BMES^XPDUTL("package reference from the PACKAGE (#9.4) file.")
+5 DO BMES^XPDUTL("This post-install job cannot be run until this problem is resolved.")
+6 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+7 SET PSOPACRF=+Y
+8 QUIT
+9 ;
GETDATE ; GET DATE/TIME OF WHEN BACKGROUND JOB SHOULD BE RUN
+1 SET ZTDTH=""
+2 SET NOW=0
+3 DO NOW^%DTC
SET (Y,TODAY)=%
DO DD^%DT
+4 DO BMES^XPDUTL("At the following prompt, enter a starting date@time or enter NOW to")
+5 DO MES^XPDUTL("queue the job immediately.")
+6 DO MES^XPDUTL("If this prompting is during patch installation, you will not see what you type.")
+7 WRITE !
KILL %DT
DO NOW^%DTC
SET %DT="RAEX"
SET %DT(0)=%
SET %DT("A")="Queue clean-up Job to run Date@Time: "
+8 DO ^%DT
KILL %DT
IF $DATA(DTOUT)!(Y<0)
DO MES^XPDUTL("Task will be queued to run NOW")
SET ZTDTH=$HOROLOG
SET NOW=1
+9 IF 'NOW
IF Y>0
Begin DoDot:1
+10 SET SAVEY=Y
+11 DO DD^%DT
+12 SET X=Y
+13 SET Y=SAVEY
End DoDot:1
ASK DO BMES^XPDUTL("Task will be queued to run "_$SELECT(NOW:"NOW",1:X)_". Is that correct? :")
+1 READ XX:300
if '$TEST
SET XX="Y"
IF $EXTRACT(XX)'="Y"
IF $EXTRACT(XX)'="y"
IF $EXTRACT(XX)'="N"
IF $EXTRACT(XX)'="n"
DO BMES^XPDUTL(" Enter Y or N")
GOTO ASK
+2 IF $EXTRACT(XX)'="Y"
IF $EXTRACT(XX)'="y"
GOTO GETDATE
+3 IF Y>0
IF ZTDTH=""
SET ZTDTH=Y
+4 IF ZTDTH=""
SET ZTDTH=$HOROLOG
+5 QUIT
