Routine: PSOELPS2

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 !",!

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="@"

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

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)

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"

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

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

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOELPS2   6152     printed  Apr 23, 2025@18:41:55                                                                                                                                                                                                    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

PSOELPS2.m