PSOPI136 ;BHM/MFR,BI - Patient Merge Clean-up ;07/10/03
;;7.0;OUTPATIENT PHARMACY;**136**;DEC 1997
;
;External reference to ^OR(100 supported by DBIA 3582
;External reference to ^OR(100 supported by DBIA 3463
;External reference to ^PS(55 supported by DBIA 2228
;External reference to GET1^DIQ supported by DBIA 2056
;External reference to DPT(OLDDFN,-9) supported by DBIA 2762
;External reference to ^XMD supported by DBIA 10070
;
I $G(XPDENV)'=1 W !,"The Environment Check Routine is designed",!,"to run during the installation step only.",! Q
W !,"This patch queues a job to perform Patient Merge Clean-up",!
REPEAT W "It should be queued to run when there are no users processing outpatient prescriptions."
S %DT="AR",%DT("A")="ENTER QUEUE DATE@TIME: ",%DT("B")="T@2000" D ^%DT
I $G(DTOUT) S XPDQUIT=2 W !,"The program did not run, the patch will not install.",! G OUT
I Y=-1 S XPDQUIT=2 W !,"The program did not run, the patch will not install..",! G OUT
D NOW^%DTC I Y'>% W !,"MUST BE IN THE FUTURE",! H 3 G REPEAT
S X=Y D H^%DTC S Y=%H_","_%T
W ! S ZTDTH=Y S ZTRTN="EN^PSOPI136",ZTDESC="Pharmacy Patient Merge Clean-up",ZTIO="",ZTSAVE("XPDQUIT")="" D ^%ZTLOAD
W !!,"JOB QUEUED AS ",$G(ZTSK),".",!
OUT K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
K X,Y,%DT
Q
;
EN N OLDDFN,NEWDFN,RXCNT,STCNT,%,X1,X2,X,RUNCNT
;
L +^XTMP("PSOPI136"):0 I '$T W "Job is already running",! G END
;
S X1=DT,X2=90 D C^%DTC S ^XTMP("PSOPI136",0)=$G(X)_"^"_DT_"^Pharmacy Patient Merge Clean-up, Run by DUZ: "_DUZ
S ^XTMP("PSOPI136",0,0)=$G(^XTMP("PSOPI136",0,0))+1,RUNCNT=^XTMP("PSOPI136",0,0)
;
D NOW^%DTC S ^XTMP("PSOPI136",RUNCNT,"START")=%
S (RXCNT,STCNT)=0
S OLDDFN=0 F S OLDDFN=$O(^DPT(OLDDFN)) Q:'OLDDFN D
. I '$D(^DPT(OLDDFN,-9)) Q ;Patient not merged
. S NEWDFN=+^DPT(OLDDFN,-9) I '$D(^DPT(NEWDFN,0)) Q
. D FIX(OLDDFN,NEWDFN)
D NOW^%DTC S ^XTMP("PSOPI136",RUNCNT,"FINISH")=%
D MAIL
;
L -^XTMP("PSOPI136")
;
END Q
;
FIX(OLDDFN,NEWDFN) ; Fix problems caused by Patient Merge
N DIE,DA,DR,EXPDT,RXIEN,ORIEN,RXST,ORST,RXSTN,ORSTN,COMM
;
S EXPDT=0 F S EXPDT=$O(^PS(55,NEWDFN,"P","A",EXPDT)) Q:'EXPDT D
. S RXIEN=0 F S RXIEN=$O(^PS(55,NEWDFN,"P","A",EXPDT,RXIEN)) Q:'RXIEN D
. . I '$D(^PSRX(RXIEN,0)) Q
. . I $P($G(^PSRX(RXIEN,0)),"^",2)=NEWDFN Q
. . S DIE=52,DA=RXIEN,DR="2///"_NEWDFN D ^DIE S RXCNT=$G(RXCNT)+1
. . S ORIEN=$P($G(^PSRX(RXIEN,"OR1")),"^",2) Q:'ORIEN
. . S RXST=+$G(^PSRX(RXIEN,"STA"))
. . S RXSTN=$$GET1^DIQ(52,RXIEN,100),ORSTN=$$GET1^DIQ(100,ORIEN,5)
. . I '$D(^XTMP("PSOPI136",RUNCNT,RXIEN)) D
. . . S ^XTMP("PSOPI136",RUNCNT,RXIEN)=OLDDFN_"^"_NEWDFN_"^"_RXSTN_"^"_ORSTN_"^^"_$H
. . I $E(RXSTN,1,10)=$E(ORSTN,1,10) Q
. . I RXST'=11,RXST'=12,RXST'=14,RXST'=15 Q
. . S STCNT=$G(STCNT)+1
. . I RXST=11 D EXP S $P(^XTMP("PSOPI136",RUNCNT,RXIEN),"^",5)="EXPIRED" Q
. . D DSC S $P(^XTMP("PSOPI136",RUNCNT,RXIEN),"^",5)="DISCONTINUED"
;
Q
;
EXP ; Sets CPRS order status to EXPIRED
I $P(^PSRX(RXIEN,0),"^",19)=2 S $P(^PSRX(RXIEN,0),"^",19)=1
S COMM="Prescription past expiration date"
D EN^PSOHLSN1(RXIEN,"SC","ZE",COMM)
I $D(^OR(100,ORIEN,3)) S $P(^OR(100,ORIEN,3),"^")=EXPDT
Q
;
DSC ; Sets CPRS order status to DISCONTINUED
N ACTLOG,LSTACT,PHARM,ACTDT,RSN,ACT0,ACTCOM,SAVEDUZ,NACT
;
S (ACTLOG,LSTACT,PHARM,ACTDT)=0
F S ACTLOG=$O(^PSRX(RXIEN,"A",ACTLOG)) Q:'ACTLOG D
. S RSN=$P($G(^PSRX(RXIEN,"A",ACTLOG,0)),"^",2)
. I RSN="C"!(RSN="L") S LSTACT=ACTLOG
I 'LSTACT S COMM="Discontinued by Pharmacy",NACT=""
I LSTACT S ACT0=$G(^PSRX(RXIEN,"A",LSTACT,0)) D
. S PHARM=$P(ACT0,"^",3),ACTCOM=$P(ACT0,"^",5)
. S ACTDT=$P(ACT0,"^"),(NACT,COMM)=""
. I ACTCOM["Renewed" D
. . S COMM="Renewed by Pharmacy"
. I ACTCOM["Auto Discontinued" D
. . S PHARM="",NACT="A",COMM=$E($P(ACTCOM,".",2),2,99)
. . S:COMM="" COMM=ACTCOM
. I ACTCOM["Discontinued During" D
. . S COMM="Discontinued by Pharmacy"
S SAVEDUZ=$G(DUZ) S:$G(PHARM) DUZ=PHARM
D EN^PSOHLSN1(RXIEN,"OD",$S(RXST=15:"RP",1:""),COMM,NACT)
S DUZ=SAVEDUZ W "."
I '$G(ACTDT) S ACTDT=DT_".2200"
I $D(^OR(100,ORIEN,3)) S $P(^OR(100,ORIEN,3),"^")=$E(ACTDT,1,12)
I $D(^OR(100,ORIEN,6)) S $P(^OR(100,ORIEN,6),"^",3)=$E(ACTDT,1,12)
;
Q
MAIL ; Send mail about the Clean-up
N CNT,DASH,START,FINISH,%,X,Y,XMDUZ,XMSUB,XMTEXT,DIFROM
;
K ^TMP("PSO",$J)
S Y=$G(^XTMP("PSOPI136",RUNCNT,"START")) D DD^%DT S START=Y
S Y=$G(^XTMP("PSOPI136",RUNCNT,"FINISH")) D DD^%DT S FINISH=Y
S XMDUZ="Patch PSO*7*136",XMY(DUZ)=""
S XMSUB="PSO*7*136 PRESCRIPTION file (#52) - Patient Merge clean up"
S CNT=0,$P(DASH,"-",79)=""
S CNT=CNT+1,^TMP("PSO",$J,CNT)="Patch PSO*7*136 PRESCRIPTION file (#52) clean-up is complete."
S CNT=CNT+1,^TMP("PSO",$J,CNT)="It started on "_$G(START)_"."
S CNT=CNT+1,^TMP("PSO",$J,CNT)="It ended on "_$G(FINISH)_"."
S CNT=CNT+1,^TMP("PSO",$J,CNT)=" "
S CNT=CNT+1,^TMP("PSO",$J,CNT)=DASH
S CNT=CNT+1,^TMP("PSO",$J,CNT)=DASH
S CNT=CNT+1,^TMP("PSO",$J,CNT)="NEW PATIENT NAME"
S X="RX",$E(X,14)="OLD PATIENT",$E(X,27)="NEW PATIENT"
S $E(X,40)="PHARM STATUS",$E(X,54)="CPRS STATUS"
S $E(X,68)="NEW CPRS ST"
S CNT=CNT+1,^TMP("PSO",$J,CNT)=X
S CNT=CNT+1,^TMP("PSO",$J,CNT)=DASH
S DA=0 F S DA=$O(^XTMP("PSOPI136",RUNCNT,DA)) Q:'DA D
. S Z=$G(^XTMP("PSOPI136",RUNCNT,DA))
. S CNT=CNT+1,^TMP("PSO",$J,CNT)=$$GET1^DIQ(2,$P(Z,"^",2)_",",.01)
. S X=$P($G(^PSRX(DA,0)),"^"),$E(X,14)=$J($P(Z,"^"),11)
. S $E(X,27)=$J($P(Z,"^",2),11),$E(X,40)=$E($P(Z,"^",3),1,12)
. S $E(X,54)=$E($P(Z,"^",4),1,12),$E(X,68)=$E($P(Z,"^",5),1,11)
. S CNT=CNT+1,^TMP("PSO",$J,CNT)=X
. S CNT=CNT+1,^TMP("PSO",$J,CNT)=DASH
S CNT=CNT+1,^TMP("PSO",$J,CNT)=" "
S CNT=CNT+1,^TMP("PSO",$J,CNT)=+$G(RXCNT)_" prescriptions had the wrong Patient IEN and have been fixed."
S CNT=CNT+1,^TMP("PSO",$J,CNT)=+$G(STCNT)_" prescriptions had their status in CPRS adjusted to match Pharmacy."
S ^TMP("PSO",$J,CNT+1)=" "
S XMTEXT="^TMP(""PSO"",$J," D ^XMD
K ^TMP("PSO",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPI136 6119 printed Sep 23, 2025@20:09:07 Page 2
PSOPI136 ;BHM/MFR,BI - Patient Merge Clean-up ;07/10/03
+1 ;;7.0;OUTPATIENT PHARMACY;**136**;DEC 1997
+2 ;
+3 ;External reference to ^OR(100 supported by DBIA 3582
+4 ;External reference to ^OR(100 supported by DBIA 3463
+5 ;External reference to ^PS(55 supported by DBIA 2228
+6 ;External reference to GET1^DIQ supported by DBIA 2056
+7 ;External reference to DPT(OLDDFN,-9) supported by DBIA 2762
+8 ;External reference to ^XMD supported by DBIA 10070
+9 ;
+10 IF $GET(XPDENV)'=1
WRITE !,"The Environment Check Routine is designed",!,"to run during the installation step only.",!
QUIT
+11 WRITE !,"This patch queues a job to perform Patient Merge Clean-up",!
REPEAT WRITE "It should be queued to run when there are no users processing outpatient prescriptions."
+1 SET %DT="AR"
SET %DT("A")="ENTER QUEUE DATE@TIME: "
SET %DT("B")="T@2000"
DO ^%DT
+2 IF $GET(DTOUT)
SET XPDQUIT=2
WRITE !,"The program did not run, the patch will not install.",!
GOTO OUT
+3 IF Y=-1
SET XPDQUIT=2
WRITE !,"The program did not run, the patch will not install..",!
GOTO OUT
+4 DO NOW^%DTC
IF Y'>%
WRITE !,"MUST BE IN THE FUTURE",!
HANG 3
GOTO REPEAT
+5 SET X=Y
DO H^%DTC
SET Y=%H_","_%T
+6 WRITE !
SET ZTDTH=Y
SET ZTRTN="EN^PSOPI136"
SET ZTDESC="Pharmacy Patient Merge Clean-up"
SET ZTIO=""
SET ZTSAVE("XPDQUIT")=""
DO ^%ZTLOAD
+7 WRITE !!,"JOB QUEUED AS ",$GET(ZTSK),".",!
OUT KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
+1 KILL X,Y,%DT
+2 QUIT
+3 ;
EN NEW OLDDFN,NEWDFN,RXCNT,STCNT,%,X1,X2,X,RUNCNT
+1 ;
+2 LOCK +^XTMP("PSOPI136"):0
IF '$TEST
WRITE "Job is already running",!
GOTO END
+3 ;
+4 SET X1=DT
SET X2=90
DO C^%DTC
SET ^XTMP("PSOPI136",0)=$GET(X)_"^"_DT_"^Pharmacy Patient Merge Clean-up, Run by DUZ: "_DUZ
+5 SET ^XTMP("PSOPI136",0,0)=$GET(^XTMP("PSOPI136",0,0))+1
SET RUNCNT=^XTMP("PSOPI136",0,0)
+6 ;
+7 DO NOW^%DTC
SET ^XTMP("PSOPI136",RUNCNT,"START")=%
+8 SET (RXCNT,STCNT)=0
+9 SET OLDDFN=0
FOR
SET OLDDFN=$ORDER(^DPT(OLDDFN))
if 'OLDDFN
QUIT
Begin DoDot:1
+10 ;Patient not merged
IF '$DATA(^DPT(OLDDFN,-9))
QUIT
+11 SET NEWDFN=+^DPT(OLDDFN,-9)
IF '$DATA(^DPT(NEWDFN,0))
QUIT
+12 DO FIX(OLDDFN,NEWDFN)
End DoDot:1
+13 DO NOW^%DTC
SET ^XTMP("PSOPI136",RUNCNT,"FINISH")=%
+14 DO MAIL
+15 ;
+16 LOCK -^XTMP("PSOPI136")
+17 ;
END QUIT
+1 ;
FIX(OLDDFN,NEWDFN) ; Fix problems caused by Patient Merge
+1 NEW DIE,DA,DR,EXPDT,RXIEN,ORIEN,RXST,ORST,RXSTN,ORSTN,COMM
+2 ;
+3 SET EXPDT=0
FOR
SET EXPDT=$ORDER(^PS(55,NEWDFN,"P","A",EXPDT))
if 'EXPDT
QUIT
Begin DoDot:1
+4 SET RXIEN=0
FOR
SET RXIEN=$ORDER(^PS(55,NEWDFN,"P","A",EXPDT,RXIEN))
if 'RXIEN
QUIT
Begin DoDot:2
+5 IF '$DATA(^PSRX(RXIEN,0))
QUIT
+6 IF $PIECE($GET(^PSRX(RXIEN,0)),"^",2)=NEWDFN
QUIT
+7 SET DIE=52
SET DA=RXIEN
SET DR="2///"_NEWDFN
DO ^DIE
SET RXCNT=$GET(RXCNT)+1
+8 SET ORIEN=$PIECE($GET(^PSRX(RXIEN,"OR1")),"^",2)
if 'ORIEN
QUIT
+9 SET RXST=+$GET(^PSRX(RXIEN,"STA"))
+10 SET RXSTN=$$GET1^DIQ(52,RXIEN,100)
SET ORSTN=$$GET1^DIQ(100,ORIEN,5)
+11 IF '$DATA(^XTMP("PSOPI136",RUNCNT,RXIEN))
Begin DoDot:3
+12 SET ^XTMP("PSOPI136",RUNCNT,RXIEN)=OLDDFN_"^"_NEWDFN_"^"_RXSTN_"^"_ORSTN_"^^"_$HOROLOG
End DoDot:3
+13 IF $EXTRACT(RXSTN,1,10)=$EXTRACT(ORSTN,1,10)
QUIT
+14 IF RXST'=11
IF RXST'=12
IF RXST'=14
IF RXST'=15
QUIT
+15 SET STCNT=$GET(STCNT)+1
+16 IF RXST=11
DO EXP
SET $PIECE(^XTMP("PSOPI136",RUNCNT,RXIEN),"^",5)="EXPIRED"
QUIT
+17 DO DSC
SET $PIECE(^XTMP("PSOPI136",RUNCNT,RXIEN),"^",5)="DISCONTINUED"
End DoDot:2
End DoDot:1
+18 ;
+19 QUIT
+20 ;
EXP ; Sets CPRS order status to EXPIRED
+1 IF $PIECE(^PSRX(RXIEN,0),"^",19)=2
SET $PIECE(^PSRX(RXIEN,0),"^",19)=1
+2 SET COMM="Prescription past expiration date"
+3 DO EN^PSOHLSN1(RXIEN,"SC","ZE",COMM)
+4 IF $DATA(^OR(100,ORIEN,3))
SET $PIECE(^OR(100,ORIEN,3),"^")=EXPDT
+5 QUIT
+6 ;
DSC ; Sets CPRS order status to DISCONTINUED
+1 NEW ACTLOG,LSTACT,PHARM,ACTDT,RSN,ACT0,ACTCOM,SAVEDUZ,NACT
+2 ;
+3 SET (ACTLOG,LSTACT,PHARM,ACTDT)=0
+4 FOR
SET ACTLOG=$ORDER(^PSRX(RXIEN,"A",ACTLOG))
if 'ACTLOG
QUIT
Begin DoDot:1
+5 SET RSN=$PIECE($GET(^PSRX(RXIEN,"A",ACTLOG,0)),"^",2)
+6 IF RSN="C"!(RSN="L")
SET LSTACT=ACTLOG
End DoDot:1
+7 IF 'LSTACT
SET COMM="Discontinued by Pharmacy"
SET NACT=""
+8 IF LSTACT
SET ACT0=$GET(^PSRX(RXIEN,"A",LSTACT,0))
Begin DoDot:1
+9 SET PHARM=$PIECE(ACT0,"^",3)
SET ACTCOM=$PIECE(ACT0,"^",5)
+10 SET ACTDT=$PIECE(ACT0,"^")
SET (NACT,COMM)=""
+11 IF ACTCOM["Renewed"
Begin DoDot:2
+12 SET COMM="Renewed by Pharmacy"
End DoDot:2
+13 IF ACTCOM["Auto Discontinued"
Begin DoDot:2
+14 SET PHARM=""
SET NACT="A"
SET COMM=$EXTRACT($PIECE(ACTCOM,".",2),2,99)
+15 if COMM=""
SET COMM=ACTCOM
End DoDot:2
+16 IF ACTCOM["Discontinued During"
Begin DoDot:2
+17 SET COMM="Discontinued by Pharmacy"
End DoDot:2
End DoDot:1
+18 SET SAVEDUZ=$GET(DUZ)
if $GET(PHARM)
SET DUZ=PHARM
+19 DO EN^PSOHLSN1(RXIEN,"OD",$SELECT(RXST=15:"RP",1:""),COMM,NACT)
+20 SET DUZ=SAVEDUZ
WRITE "."
+21 IF '$GET(ACTDT)
SET ACTDT=DT_".2200"
+22 IF $DATA(^OR(100,ORIEN,3))
SET $PIECE(^OR(100,ORIEN,3),"^")=$EXTRACT(ACTDT,1,12)
+23 IF $DATA(^OR(100,ORIEN,6))
SET $PIECE(^OR(100,ORIEN,6),"^",3)=$EXTRACT(ACTDT,1,12)
+24 ;
+25 QUIT
MAIL ; Send mail about the Clean-up
+1 NEW CNT,DASH,START,FINISH,%,X,Y,XMDUZ,XMSUB,XMTEXT,DIFROM
+2 ;
+3 KILL ^TMP("PSO",$JOB)
+4 SET Y=$GET(^XTMP("PSOPI136",RUNCNT,"START"))
DO DD^%DT
SET START=Y
+5 SET Y=$GET(^XTMP("PSOPI136",RUNCNT,"FINISH"))
DO DD^%DT
SET FINISH=Y
+6 SET XMDUZ="Patch PSO*7*136"
SET XMY(DUZ)=""
+7 SET XMSUB="PSO*7*136 PRESCRIPTION file (#52) - Patient Merge clean up"
+8 SET CNT=0
SET $PIECE(DASH,"-",79)=""
+9 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)="Patch PSO*7*136 PRESCRIPTION file (#52) clean-up is complete."
+10 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)="It started on "_$GET(START)_"."
+11 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)="It ended on "_$GET(FINISH)_"."
+12 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)=" "
+13 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)=DASH
+14 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)=DASH
+15 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)="NEW PATIENT NAME"
+16 SET X="RX"
SET $EXTRACT(X,14)="OLD PATIENT"
SET $EXTRACT(X,27)="NEW PATIENT"
+17 SET $EXTRACT(X,40)="PHARM STATUS"
SET $EXTRACT(X,54)="CPRS STATUS"
+18 SET $EXTRACT(X,68)="NEW CPRS ST"
+19 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)=X
+20 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)=DASH
+21 SET DA=0
FOR
SET DA=$ORDER(^XTMP("PSOPI136",RUNCNT,DA))
if 'DA
QUIT
Begin DoDot:1
+22 SET Z=$GET(^XTMP("PSOPI136",RUNCNT,DA))
+23 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)=$$GET1^DIQ(2,$PIECE(Z,"^",2)_",",.01)
+24 SET X=$PIECE($GET(^PSRX(DA,0)),"^")
SET $EXTRACT(X,14)=$JUSTIFY($PIECE(Z,"^"),11)
+25 SET $EXTRACT(X,27)=$JUSTIFY($PIECE(Z,"^",2),11)
SET $EXTRACT(X,40)=$EXTRACT($PIECE(Z,"^",3),1,12)
+26 SET $EXTRACT(X,54)=$EXTRACT($PIECE(Z,"^",4),1,12)
SET $EXTRACT(X,68)=$EXTRACT($PIECE(Z,"^",5),1,11)
+27 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)=X
+28 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)=DASH
End DoDot:1
+29 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)=" "
+30 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)=+$GET(RXCNT)_" prescriptions had the wrong Patient IEN and have been fixed."
+31 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,CNT)=+$GET(STCNT)_" prescriptions had their status in CPRS adjusted to match Pharmacy."
+32 SET ^TMP("PSO",$JOB,CNT+1)=" "
+33 SET XMTEXT="^TMP(""PSO"",$J,"
DO ^XMD
+34 KILL ^TMP("PSO",$JOB)
+35 QUIT
