| 1 | PSOHLEXP ;BIR/RTR-Auto expire prescriptions ;10/10/96
|
|---|
| 2 | ;;7.0;OUTPATIENT PHARMACY;**10,22,36,73,148**;DEC 1997
|
|---|
| 3 | ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
|
|---|
| 4 | ;
|
|---|
| 5 | EN N PSOEXRX,PSOEXCOM,PSOEXSTS,SUSD,PSOEXSTA,ZZDT,IFN,NODE,RF,PIFN,PSUSD,PRFDT,PDA,PSDTEST,ORN
|
|---|
| 6 | I '$G(DT) S DT=$$DT^XLFDT
|
|---|
| 7 | S X1=DT,X2=-1 D C^%DTC S ZZDT=X
|
|---|
| 8 | F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX D:$D(^PSRX(PSOEXRX,0))
|
|---|
| 9 | .Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT
|
|---|
| 10 | .S DA=$O(^PS(52.5,"B",PSOEXRX,0))
|
|---|
| 11 | .I DA S SUSD=$P($G(^PS(52.5,DA,0)),"^",2) I SUSD,$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK
|
|---|
| 12 | .I $D(^PS(52.4,PSOEXRX,0)) S DIK="^PS(52.4,",DA=PSOEXRX D ^DIK K DIK
|
|---|
| 13 | .I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")=""
|
|---|
| 14 | .S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^")
|
|---|
| 15 | .Q:PSOEXSTA=13!(PSOEXSTA="")
|
|---|
| 16 | .I '$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) D EN^PSOHLSN1(PSOEXRX,"ZC","") I $P($G(^PSRX(PSOEXRX,"OR1")),"^",2) D
|
|---|
| 17 | ..I PSOEXSTA=12!(PSOEXSTA=14)!(PSOEXSTA=15) D EN^PSOHLSN1(PSOEXRX,"OD","","","A")
|
|---|
| 18 | .I PSOEXSTA=11 S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) I ORN,+$$STATUS^ORQOR2(ORN)=6 D
|
|---|
| 19 | ..S $P(^PSRX(PSOEXRX,0),"^",19)=1
|
|---|
| 20 | ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
|
|---|
| 21 | .Q:PSOEXSTA>9
|
|---|
| 22 | .S $P(^PSRX(PSOEXRX,"STA"),"^")=11
|
|---|
| 23 | .I '$G(PSUSD) D REVERSE^PSOBPSU1(PSOEXRX,0,"DE",5,"RX EXPIRED")
|
|---|
| 24 | .S (PIFN,PSUSD,PRFDT)=0 F S PIFN=$O(^PSRX(PSOEXRX,1,PIFN)) Q:'PIFN S PSUSD=PIFN,PRFDT=+$P($G(^PSRX(PSOEXRX,1,PIFN,0)),"^")
|
|---|
| 25 | .I $G(PSUSD) I '$P($G(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18) S PSDTEST=0 D I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET
|
|---|
| 26 | ..D REVERSE^PSOBPSU1(PSOEXRX,PSUSD,"DE",5,"RX EXPIRED")
|
|---|
| 27 | ..F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,"L",PDA)) Q:'PDA I $P($G(^PSRX(PSOEXRX,"L",PDA,0)),"^",2)=PSUSD S PSDTEST=1
|
|---|
| 28 | ..S DA=PSOEXRX K CMOP D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q
|
|---|
| 29 | ..S PSDTEST=1
|
|---|
| 30 | .Q:'$P($G(^PSRX(PSOEXRX,"OR1")),"^",2)
|
|---|
| 31 | .S $P(^PSRX(PSOEXRX,0),"^",19)=1
|
|---|
| 32 | .S PSOEXCOM="Prescription past expiration date" D EN^PSOHLSN1(PSOEXRX,"SC","ZE",PSOEXCOM)
|
|---|
| 33 | Q
|
|---|
| 34 | NSET ;
|
|---|
| 35 | N PSONM,PSONMX
|
|---|
| 36 | S PSONM="" F PSONMX=0:0 S PSONMX=$O(^PSRX(PSOEXRX,1,PSONMX)) Q:'PSONMX S PSONM=PSONMX
|
|---|
| 37 | S ^PSRX(PSOEXRX,1,0)="^52.1DA^"_$G(PSONM)_"^"_$G(PSONM)
|
|---|
| 38 | Q
|
|---|
| 39 | SETUP ;
|
|---|
| 40 | K %DT,DIC,DTOUT S DIC(0)="XZM",DIC="^DIC(19.2,",X="PSO EXPIRE PRESCRIPTIONS" D ^DIC
|
|---|
| 41 | I +Y>0 D EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS") K DIC,Y,X Q
|
|---|
| 42 | D RESCH^XUTMOPT("PSO EXPIRE PRESCRIPTIONS","","","24H","L"),EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS") K DIC,Y,X
|
|---|
| 43 | OUT Q
|
|---|
