- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP3.m
r613 r623 1 PSOHELP3 ;BHAM ISC/SAB - outpatient utility routine #4 ;2/17/93 18:00:36 2 ;;7.0;OUTPATIENT PHARMACY;**20,291**;DEC 1997;Build 2 3 XREF ;code to create 'APD' xref on Drug Interaction file (#56) 4 ;I '$D(ZTSK),'$D(PSMSG) D WAIT^DICD W "Building 'APD' X-Ref." 5 ;The following code accessing files 56 and 50.416 is no longer executed 6 S ID1=$P(^PS(56,DA,0),"^",2),ID2=$P(^(0),"^",3),TOT=0 7 F I1=0:0 S I1=$O(^PS(50.416,ID1,1,I1)) Q:'I1 S R2=$P(^(I1,0),"^") F I2=0:0 S I2=$O(^PS(50.416,ID2,1,I2)) Q:'I2 S D2=$P(^(I2,0),"^") W:+$G(PSMSG) "." D SEC 8 F I1=0:0 S I1=$O(^PS(50.416,"APS",ID1,I1)) Q:'I1 F I3=0:0 S I3=$O(^PS(50.416,I1,1,I3)) Q:'I3 S R2=$P(^(I3,0),"^") F I5=0:0 S I5=$O(^PS(50.416,"APS",ID2,I5)) Q:'I5 F I6=0:0 S I6=$O(^PS(50.416,I5,1,I6)) Q:'I6 S D2=$P(^(I6,0),"^") D SEC 9 F I1=0:0 S I1=$O(^PS(50.416,ID1,1,I1)) Q:'I1 S R2=$P(^(I1,0),"^") F I5=0:0 S I5=$O(^PS(50.416,"APS",ID2,I5)) Q:'I5 F I6=0:0 S I6=$O(^PS(50.416,I5,1,I6)) Q:'I6 S D2=$P(^(I6,0),"^") D SEC 10 F I2=0:0 S I2=$O(^PS(50.416,ID2,1,I2)) Q:'I2 S D2=$P(^(I2,0),"^") F I1=0:0 S I1=$O(^PS(50.416,"APS",ID1,I1)) Q:'I1 F I3=0:0 S I3=$O(^PS(50.416,I1,1,I3)) Q:'I3 S R2=$P(^(I3,0),"^") D SEC 11 S $P(^PS(56,DA,0),"^",6)=TOT 12 EX K TOT,I5,I6,D2,I4,I3,PRI,I1,I2,R2,PS1,PS2,ID2,ID1 13 Q 14 SEC I +$G(DEL) K ^PS(56,"APD",R2,D2,DA),^PS(56,"APD",D2,R2,DA) Q 15 S ^PS(56,"APD",R2,D2,DA)="",^PS(56,"APD",D2,R2,DA)="",TOT=TOT+2 16 Q 17 DRUG ;selects drug and updates Rx file with cost (pso*7*20) 18 W !!,"This option will update the drug cost on all fills in the PRESCRIPTION" 19 W !,"file (#52) based on the selected date range and the current cost in the" 20 W !,"DRUG file (#50).",! 21 K X,Y,DA,DIC S DIC(0)="AQEM",DIC=50 D ^DIC I $G(DUOUT) K DIC,Y,X,DA Q 22 I Y<0 G OUT 23 S (DRG,DA)=+Y K DIC,DR,DIQ S DIC=50,DR=16,DIQ="PSODRG",DIQ(0)="I" 24 D EN^DIQ1 S COST=PSODRG(50,DA,16,"I") K PSODRG,DIC,DA,DR,DIQ,DIR 25 W ! S DIR("A")="Do you want to exclude Refills and Partials",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR I $G(DIRUT) K COST,X,DRG,Y Q 26 S REF=$S(Y:0,1:1) 27 S X1=DT,X2=-485 D C^%DTC S (DEF,Y)=X X ^DD("DD") 28 W !!,"You can only go back One Year plus 120 days." 29 S %DT(0)=DEF,%DT="AQEX",%DT("A")="Enter starting fill date: ",%DT("B")=Y D ^%DT K %DT("B"),DEF I Y<0!($D(DTOUT)) K REF,COST,DRG,X,Y Q 30 S (FBCK,%DT(0))=Y,%DT("A")="Enter ending fill date: " D ^%DT 31 K %DT I Y<0!($D(DTOUT)) K FBCK,REF,COST,DRG,X,Y Q 32 S FAHD=Y 33 S PSOFUTR=0 I FAHD>(DT-1) S PSOFUTR=1 D 34 .W !!,"Since you selected an end fill date of today or in the future, this option" 35 .W !,"will update the cost for all existing and suspended fills that have a" 36 .W !,"fill date in the future.",! 37 K DIR,X,Y S DIR(0)="Y",DIR("A")="Do you want to Queue to run at a specific Time",DIR("B")="Yes" D ^DIR K DIR I $D(DIRUT) G OUT 38 I Y S PSOQ=1 K ZTDTH D G OUT 39 .S ZTRTN="EN^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx Cost Update" 40 .F G="REF","COST","DRG","FBCK","FAHD","PSOQ","PSOFUTR" S:$D(@G) ZTSAVE(G)="" 41 .D ^%ZTLOAD I $D(ZTSK) W !!,"Rxs Cost Update Queued",! K ZTSK 42 EN W:'$G(PSOQ) !,"Updating cost. Please wait... " 43 S FDT=FBCK-1 F S FDT=$O(^PSRX("ADL",FDT)) Q:'FDT D Q:FDT>FAHD 44 .I '$G(PSOFUTR) I FDT>FAHD Q 45 .S RXN=0 F S RXN=$O(^PSRX("ADL",FDT,DRG,RXN)) Q:'RXN D W:'$G(PSOQ) "." 46 ..I $P($G(^PSRX(RXN,0)),"^",6)=DRG,$P($G(^(2)),"^",2)=FDT S $P(^PSRX(RXN,0),"^",17)=COST 47 I 'REF G OUT 48 D REFILL,PARTIAL 49 OUT K G,COST,I,X,Y,REF,RXN,FDT,FAHD,FBCK,DRG,PSOQ,DIRUT,PSOFUTR I $D(ZTQUEUED) S ZTREQ="@" 50 Q 51 POST ;post install entry point. builds new "ADL" xref for file 52 pso*7*20 52 S ZTRTN="EN1^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx XREF Update" 53 S ZTDTH=$H D ^%ZTLOAD I $D(ZTSK) D BMES^XPDUTL(" Post Install Background Job Queued.") K ZTSK 54 Q 55 EN1 K ^PSRX("ADL") S X1=DT,X2=-485 D C^%DTC S DEF=X-1 W !,"DEF: "_DEF 56 F S DEF=$O(^PSRX("AD",DEF)) Q:'DEF F IFN=0:0 S IFN=$O(^PSRX("AD",DEF,IFN)) Q:'IFN S FTY="" F S FTY=$O(^PSRX("AD",DEF,IFN,FTY)) Q:FTY="" I FTY=0 D 57 .I $P($G(^PSRX(IFN,2)),"^",2),$P($G(^(0)),"^",6) S ^PSRX("ADL",$P($G(^PSRX(IFN,2)),"^",2),$P($G(^(0)),"^",6),IFN)="" 58 K X,Y,DEF,FTY,IFN S ZTREQ="@" 59 Q 60 REFILL ; 61 N FILL,FDT,RXN 62 S FDT=FBCK-1 F S FDT=$O(^PSRX("AD",FDT)) Q:'FDT D Q:FDT>FAHD 63 .I '$G(PSOFUTR),FDT>FAHD Q 64 .S RXN="" F S RXN=$O(^PSRX("AD",FDT,RXN)) Q:'RXN D 65 ..I $P($G(^PSRX(RXN,0)),"^",6)'=DRG Q 66 ..S FILL=0 F S FILL=$O(^PSRX("AD",FDT,RXN,FILL)) Q:'FILL I $D(^PSRX(RXN,1,FILL,0)) S $P(^(0),"^",11)=COST 67 Q 68 PARTIAL ; 69 N FILL,FDT,RXN 70 S FDT=FBCK-1 F S FDT=$O(^PSRX("ADP",FDT)) Q:'FDT D Q:FDT>FAHD 71 .I '$G(PSOFUTR),FDT>FAHD Q 72 .S RXN="" F S RXN=$O(^PSRX("ADP",FDT,RXN)) Q:'RXN D 73 ..I $P($G(^PSRX(RXN,0)),"^",6)'=DRG Q 74 ..S FILL=0 F S FILL=$O(^PSRX("ADP",FDT,RXN,FILL)) Q:'FILL I $D(^PSRX(RXN,"P",FILL,0)) S $P(^(0),"^",11)=COST 75 Q 1 PSOHELP3 ;BHAM ISC/SAB - outpatient utility routine #4 ;2/17/93 18:00:36 2 ;;7.0;OUTPATIENT PHARMACY;**20**;DEC 1997 3 XREF ;code to create 'APD' xref on Drug Interaction file (#56) 4 ;I '$D(ZTSK),'$D(PSMSG) D WAIT^DICD W "Building 'APD' X-Ref." 5 ;The following code accessing files 56 and 50.416 is no longer executed 6 S ID1=$P(^PS(56,DA,0),"^",2),ID2=$P(^(0),"^",3),TOT=0 7 F I1=0:0 S I1=$O(^PS(50.416,ID1,1,I1)) Q:'I1 S R2=$P(^(I1,0),"^") F I2=0:0 S I2=$O(^PS(50.416,ID2,1,I2)) Q:'I2 S D2=$P(^(I2,0),"^") W:+$G(PSMSG) "." D SEC 8 F I1=0:0 S I1=$O(^PS(50.416,"APS",ID1,I1)) Q:'I1 F I3=0:0 S I3=$O(^PS(50.416,I1,1,I3)) Q:'I3 S R2=$P(^(I3,0),"^") F I5=0:0 S I5=$O(^PS(50.416,"APS",ID2,I5)) Q:'I5 F I6=0:0 S I6=$O(^PS(50.416,I5,1,I6)) Q:'I6 S D2=$P(^(I6,0),"^") D SEC 9 F I1=0:0 S I1=$O(^PS(50.416,ID1,1,I1)) Q:'I1 S R2=$P(^(I1,0),"^") F I5=0:0 S I5=$O(^PS(50.416,"APS",ID2,I5)) Q:'I5 F I6=0:0 S I6=$O(^PS(50.416,I5,1,I6)) Q:'I6 S D2=$P(^(I6,0),"^") D SEC 10 F I2=0:0 S I2=$O(^PS(50.416,ID2,1,I2)) Q:'I2 S D2=$P(^(I2,0),"^") F I1=0:0 S I1=$O(^PS(50.416,"APS",ID1,I1)) Q:'I1 F I3=0:0 S I3=$O(^PS(50.416,I1,1,I3)) Q:'I3 S R2=$P(^(I3,0),"^") D SEC 11 S $P(^PS(56,DA,0),"^",6)=TOT 12 EX K TOT,I5,I6,D2,I4,I3,PRI,I1,I2,R2,PS1,PS2,ID2,ID1 13 Q 14 SEC I +$G(DEL) K ^PS(56,"APD",R2,D2,DA),^PS(56,"APD",D2,R2,DA) Q 15 S ^PS(56,"APD",R2,D2,DA)="",^PS(56,"APD",D2,R2,DA)="",TOT=TOT+2 16 Q 17 DRUG ;selects drug and updates Rx file with cost (pso*7*20) 18 K X,Y,DA,DIC S DIC(0)="AQEM",DIC=50 D ^DIC I $G(DUOUT) K DIC,Y,X,DA Q 19 I Y<0 G OUT 20 S (DRG,DA)=+Y K DIC,DR,DIQ S DIC=50,DR=16,DIQ="PSODRG",DIQ(0)="I" 21 D EN^DIQ1 S COST=PSODRG(50,DA,16,"I") K PSODRG,DIC,DA,DR,DIQ,DIR 22 W ! S DIR("A")="Do you want to update cost on Refills and Partials too",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR I $G(DIRUT) K COST,X,DRG,Y Q 23 S REF=$S(Y:Y,1:0),X1=DT,X2=-485 D C^%DTC S (DEF,Y)=X X ^DD("DD") 24 W !!,"You can only go back One Year plus 120 days." 25 S %DT(0)=DEF,%DT="AQEX",%DT("A")="How far BACK do you want to go: ",%DT("B")=Y D ^%DT K %DT("B"),DEF I Y<0!($D(DTOUT)) K REF,COST,DRG,X,Y Q 26 S (FBCK,%DT(0))=Y,%DT("A")="How far AHEAD do you want to go: " D ^%DT 27 K %DT I Y<0!($D(DTOUT)) K FBCK,REF,COST,DRG,X,Y Q 28 S FAHD=Y K DIR,X,Y S DIR(0)="Y",DIR("A")="Do you want to Queue to run at a specific Time",DIR("B")="Yes" D ^DIR K DIR I $D(DIRUT) G OUT 29 I Y S PSOQ=1 K ZTDTH D G OUT 30 .S ZTRTN="EN^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx Cost Update" 31 .F G="REF","COST","DRG","FBCK","FAHD","PSOQ" S:$D(@G) ZTSAVE(G)="" 32 .D ^%ZTLOAD I $D(ZTSK) W !,"Rxs Cost Update Queued" K ZTSK 33 EN W:'$G(PSOQ) ! S FDT=FBCK-1 F S FDT=$O(^PSRX("ADL",FDT)) Q:'FDT!(FDT>FAHD) F RXN=0:0 S RXN=$O(^PSRX("ADL",FDT,DRG,RXN)) Q:'RXN D W:'$G(PSOQ) "." 34 .I $P($G(^PSRX(RXN,0)),"^",6)=DRG,$P($G(^(2)),"^",2)=FDT S $P(^PSRX(RXN,0),"^",17)=COST 35 .Q:'REF 36 .F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I S $P(^PSRX(RXN,1,I,0),"^",11)=COST 37 .F I=0:0 S I=$O(^PSRX(RXN,"P",I)) Q:'I S $P(^PSRX(RXN,"P",I,0),"^",11)=COST 38 OUT K G,COST,I,X,Y,REF,RXN,FDT,FAHD,FBCK,DRG,PSOQ,DIRUT I $D(ZTQUEUED) S ZTREQ="@" 39 Q 40 POST ;post install entry point. builds new "ADL" xref for file 52 pso*7*20 41 S ZTRTN="EN1^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx XREF Update" 42 S ZTDTH=$H D ^%ZTLOAD I $D(ZTSK) D BMES^XPDUTL(" Post Install Background Job Queued.") K ZTSK 43 Q 44 EN1 K ^PSRX("ADL") S X1=DT,X2=-485 D C^%DTC S DEF=X-1 W !,"DEF: "_DEF 45 F S DEF=$O(^PSRX("AD",DEF)) Q:'DEF F IFN=0:0 S IFN=$O(^PSRX("AD",DEF,IFN)) Q:'IFN S FTY="" F S FTY=$O(^PSRX("AD",DEF,IFN,FTY)) Q:FTY="" I FTY=0 D 46 .I $P($G(^PSRX(IFN,2)),"^",2),$P($G(^(0)),"^",6) S ^PSRX("ADL",$P($G(^PSRX(IFN,2)),"^",2),$P($G(^(0)),"^",6),IFN)="" 47 K X,Y,DEF,FTY,IFN S ZTREQ="@" 48 Q
Note:
See TracChangeset
for help on using the changeset viewer.
