source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPI136.m@ 1119

Last change on this file since 1119 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1PSOPI136 ;BHM/MFR,BI - Patient Merge Clean-up ;07/10/03
2 ;;7.0;OUTPATIENT PHARMACY;**136**;DEC 1997
3 ;
4 ;External reference to ^OR(100 supported by DBIA 3582
5 ;External reference to ^OR(100 supported by DBIA 3463
6 ;External reference to ^PS(55 supported by DBIA 2228
7 ;External reference to GET1^DIQ supported by DBIA 2056
8 ;External reference to DPT(OLDDFN,-9) supported by DBIA 2762
9 ;External reference to ^XMD supported by DBIA 10070
10 ;
11 I $G(XPDENV)'=1 W !,"The Environment Check Routine is designed",!,"to run during the installation step only.",! Q
12 W !,"This patch queues a job to perform Patient Merge Clean-up",!
13REPEAT W "It should be queued to run when there are no users processing outpatient prescriptions."
14 S %DT="AR",%DT("A")="ENTER QUEUE DATE@TIME: ",%DT("B")="T@2000" D ^%DT
15 I $G(DTOUT) S XPDQUIT=2 W !,"The program did not run, the patch will not install.",! G OUT
16 I Y=-1 S XPDQUIT=2 W !,"The program did not run, the patch will not install..",! G OUT
17 D NOW^%DTC I Y'>% W !,"MUST BE IN THE FUTURE",! H 3 G REPEAT
18 S X=Y D H^%DTC S Y=%H_","_%T
19 W ! S ZTDTH=Y S ZTRTN="EN^PSOPI136",ZTDESC="Pharmacy Patient Merge Clean-up",ZTIO="",ZTSAVE("XPDQUIT")="" D ^%ZTLOAD
20 W !!,"JOB QUEUED AS ",$G(ZTSK),".",!
21OUT K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
22 K X,Y,%DT
23 Q
24 ;
25EN N OLDDFN,NEWDFN,RXCNT,STCNT,%,X1,X2,X,RUNCNT
26 ;
27 L +^XTMP("PSOPI136"):0 I '$T W "Job is already running",! G END
28 ;
29 S X1=DT,X2=90 D C^%DTC S ^XTMP("PSOPI136",0)=$G(X)_"^"_DT_"^Pharmacy Patient Merge Clean-up, Run by DUZ: "_DUZ
30 S ^XTMP("PSOPI136",0,0)=$G(^XTMP("PSOPI136",0,0))+1,RUNCNT=^XTMP("PSOPI136",0,0)
31 ;
32 D NOW^%DTC S ^XTMP("PSOPI136",RUNCNT,"START")=%
33 S (RXCNT,STCNT)=0
34 S OLDDFN=0 F S OLDDFN=$O(^DPT(OLDDFN)) Q:'OLDDFN D
35 . I '$D(^DPT(OLDDFN,-9)) Q ;Patient not merged
36 . S NEWDFN=+^DPT(OLDDFN,-9) I '$D(^DPT(NEWDFN,0)) Q
37 . D FIX(OLDDFN,NEWDFN)
38 D NOW^%DTC S ^XTMP("PSOPI136",RUNCNT,"FINISH")=%
39 D MAIL
40 ;
41 L -^XTMP("PSOPI136")
42 ;
43END Q
44 ;
45FIX(OLDDFN,NEWDFN) ; Fix problems caused by Patient Merge
46 N DIE,DA,DR,EXPDT,RXIEN,ORIEN,RXST,ORST,RXSTN,ORSTN,COMM
47 ;
48 S EXPDT=0 F S EXPDT=$O(^PS(55,NEWDFN,"P","A",EXPDT)) Q:'EXPDT D
49 . S RXIEN=0 F S RXIEN=$O(^PS(55,NEWDFN,"P","A",EXPDT,RXIEN)) Q:'RXIEN D
50 . . I '$D(^PSRX(RXIEN,0)) Q
51 . . I $P($G(^PSRX(RXIEN,0)),"^",2)=NEWDFN Q
52 . . S DIE=52,DA=RXIEN,DR="2///"_NEWDFN D ^DIE S RXCNT=$G(RXCNT)+1
53 . . S ORIEN=$P($G(^PSRX(RXIEN,"OR1")),"^",2) Q:'ORIEN
54 . . S RXST=+$G(^PSRX(RXIEN,"STA"))
55 . . S RXSTN=$$GET1^DIQ(52,RXIEN,100),ORSTN=$$GET1^DIQ(100,ORIEN,5)
56 . . I '$D(^XTMP("PSOPI136",RUNCNT,RXIEN)) D
57 . . . S ^XTMP("PSOPI136",RUNCNT,RXIEN)=OLDDFN_"^"_NEWDFN_"^"_RXSTN_"^"_ORSTN_"^^"_$H
58 . . I $E(RXSTN,1,10)=$E(ORSTN,1,10) Q
59 . . I RXST'=11,RXST'=12,RXST'=14,RXST'=15 Q
60 . . S STCNT=$G(STCNT)+1
61 . . I RXST=11 D EXP S $P(^XTMP("PSOPI136",RUNCNT,RXIEN),"^",5)="EXPIRED" Q
62 . . D DSC S $P(^XTMP("PSOPI136",RUNCNT,RXIEN),"^",5)="DISCONTINUED"
63 ;
64 Q
65 ;
66EXP ; Sets CPRS order status to EXPIRED
67 I $P(^PSRX(RXIEN,0),"^",19)=2 S $P(^PSRX(RXIEN,0),"^",19)=1
68 S COMM="Prescription past expiration date"
69 D EN^PSOHLSN1(RXIEN,"SC","ZE",COMM)
70 I $D(^OR(100,ORIEN,3)) S $P(^OR(100,ORIEN,3),"^")=EXPDT
71 Q
72 ;
73DSC ; Sets CPRS order status to DISCONTINUED
74 N ACTLOG,LSTACT,PHARM,ACTDT,RSN,ACT0,ACTCOM,SAVEDUZ,NACT
75 ;
76 S (ACTLOG,LSTACT,PHARM,ACTDT)=0
77 F S ACTLOG=$O(^PSRX(RXIEN,"A",ACTLOG)) Q:'ACTLOG D
78 . S RSN=$P($G(^PSRX(RXIEN,"A",ACTLOG,0)),"^",2)
79 . I RSN="C"!(RSN="L") S LSTACT=ACTLOG
80 I 'LSTACT S COMM="Discontinued by Pharmacy",NACT=""
81 I LSTACT S ACT0=$G(^PSRX(RXIEN,"A",LSTACT,0)) D
82 . S PHARM=$P(ACT0,"^",3),ACTCOM=$P(ACT0,"^",5)
83 . S ACTDT=$P(ACT0,"^"),(NACT,COMM)=""
84 . I ACTCOM["Renewed" D
85 . . S COMM="Renewed by Pharmacy"
86 . I ACTCOM["Auto Discontinued" D
87 . . S PHARM="",NACT="A",COMM=$E($P(ACTCOM,".",2),2,99)
88 . . S:COMM="" COMM=ACTCOM
89 . I ACTCOM["Discontinued During" D
90 . . S COMM="Discontinued by Pharmacy"
91 S SAVEDUZ=$G(DUZ) S:$G(PHARM) DUZ=PHARM
92 D EN^PSOHLSN1(RXIEN,"OD",$S(RXST=15:"RP",1:""),COMM,NACT)
93 S DUZ=SAVEDUZ W "."
94 I '$G(ACTDT) S ACTDT=DT_".2200"
95 I $D(^OR(100,ORIEN,3)) S $P(^OR(100,ORIEN,3),"^")=$E(ACTDT,1,12)
96 I $D(^OR(100,ORIEN,6)) S $P(^OR(100,ORIEN,6),"^",3)=$E(ACTDT,1,12)
97 ;
98 Q
99MAIL ; Send mail about the Clean-up
100 N CNT,DASH,START,FINISH,%,X,Y,XMDUZ,XMSUB,XMTEXT,DIFROM
101 ;
102 K ^TMP("PSO",$J)
103 S Y=$G(^XTMP("PSOPI136",RUNCNT,"START")) D DD^%DT S START=Y
104 S Y=$G(^XTMP("PSOPI136",RUNCNT,"FINISH")) D DD^%DT S FINISH=Y
105 S XMDUZ="Patch PSO*7*136",XMY(DUZ)=""
106 S XMSUB="PSO*7*136 PRESCRIPTION file (#52) - Patient Merge clean up"
107 S CNT=0,$P(DASH,"-",79)=""
108 S CNT=CNT+1,^TMP("PSO",$J,CNT)="Patch PSO*7*136 PRESCRIPTION file (#52) clean-up is complete."
109 S CNT=CNT+1,^TMP("PSO",$J,CNT)="It started on "_$G(START)_"."
110 S CNT=CNT+1,^TMP("PSO",$J,CNT)="It ended on "_$G(FINISH)_"."
111 S CNT=CNT+1,^TMP("PSO",$J,CNT)=" "
112 S CNT=CNT+1,^TMP("PSO",$J,CNT)=DASH
113 S CNT=CNT+1,^TMP("PSO",$J,CNT)=DASH
114 S CNT=CNT+1,^TMP("PSO",$J,CNT)="NEW PATIENT NAME"
115 S X="RX",$E(X,14)="OLD PATIENT",$E(X,27)="NEW PATIENT"
116 S $E(X,40)="PHARM STATUS",$E(X,54)="CPRS STATUS"
117 S $E(X,68)="NEW CPRS ST"
118 S CNT=CNT+1,^TMP("PSO",$J,CNT)=X
119 S CNT=CNT+1,^TMP("PSO",$J,CNT)=DASH
120 S DA=0 F S DA=$O(^XTMP("PSOPI136",RUNCNT,DA)) Q:'DA D
121 . S Z=$G(^XTMP("PSOPI136",RUNCNT,DA))
122 . S CNT=CNT+1,^TMP("PSO",$J,CNT)=$$GET1^DIQ(2,$P(Z,"^",2)_",",.01)
123 . S X=$P($G(^PSRX(DA,0)),"^"),$E(X,14)=$J($P(Z,"^"),11)
124 . S $E(X,27)=$J($P(Z,"^",2),11),$E(X,40)=$E($P(Z,"^",3),1,12)
125 . S $E(X,54)=$E($P(Z,"^",4),1,12),$E(X,68)=$E($P(Z,"^",5),1,11)
126 . S CNT=CNT+1,^TMP("PSO",$J,CNT)=X
127 . S CNT=CNT+1,^TMP("PSO",$J,CNT)=DASH
128 S CNT=CNT+1,^TMP("PSO",$J,CNT)=" "
129 S CNT=CNT+1,^TMP("PSO",$J,CNT)=+$G(RXCNT)_" prescriptions had the wrong Patient IEN and have been fixed."
130 S CNT=CNT+1,^TMP("PSO",$J,CNT)=+$G(STCNT)_" prescriptions had their status in CPRS adjusted to match Pharmacy."
131 S ^TMP("PSO",$J,CNT+1)=" "
132 S XMTEXT="^TMP(""PSO"",$J," D ^XMD
133 K ^TMP("PSO",$J)
134 Q
Note: See TracBrowser for help on using the repository browser.