- 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 Mar 13, 2025@21:37:35 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
