PSOPOS12 ;VRN/MFR - Patient Merge Clean-up ;10/17/03
;;7.0;OUTPATIENT PHARMACY;**154**;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 ^XMD supported by DBIA 10070
;
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 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 $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
. . D DSC
;
K OLDDFN,NEWDFN
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
PSOPOS12 ;VRN/MFR - Patient Merge Clean-up ;10/17/03
+1 ;;7.0;OUTPATIENT PHARMACY;**154**;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 ^XMD supported by DBIA 10070
+8 ;
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
+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 $EXTRACT(RXSTN,1,10)=$EXTRACT(ORSTN,1,10)
QUIT
+12 IF RXST'=11
IF RXST'=12
IF RXST'=14
IF RXST'=15
QUIT
+13 SET STCNT=$GET(STCNT)+1
+14 IF RXST=11
DO EXP
+15 DO DSC
End DoDot:2
End DoDot:1
+16 ;
+17 KILL OLDDFN,NEWDFN
+18 QUIT
+19 ;
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
