- 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
