Changeset 636 for FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP3.m

Timestamp:

Dec 4, 2009, 8:26:01 PM (14 years ago)

Author:

George Lilly

Message:

WorldVistAEHR overlayed on FOIAVistA

Location:

FOIAVistA/tag/r

Files:

• . (copied) (copied from FOIAVistA/trunk/r )
• OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP3.m (modified) (3 diffs)

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP3.m

@@ -1 +1 @@
 PSOHELP3 ;BHAM ISC/SAB - outpatient utility routine #4 ;2/17/93 18:00:36
- ;;7.0;OUTPATIENT PHARMACY;**20,291**;DEC 1997;Build 2
+ ;;7.0;OUTPATIENT PHARMACY;**20**;DEC 1997
 XREF ;code to create 'APD' xref on Drug Interaction file (#56)
  ;I '$D(ZTSK),'$D(PSMSG) D WAIT^DICD W "Building 'APD' X-Ref."
@@ -16 +16 @@
  Q
 DRUG ;selects drug and updates Rx file with cost (pso*7*20)
- W !!,"This option will update the drug cost on all fills in the PRESCRIPTION"
- W !,"file (#52) based on the selected date range and the current cost in the"
- W !,"DRUG file (#50).",!
  K X,Y,DA,DIC S DIC(0)="AQEM",DIC=50 D ^DIC I $G(DUOUT) K DIC,Y,X,DA Q
  I Y<0 G OUT
  S (DRG,DA)=+Y K DIC,DR,DIQ S DIC=50,DR=16,DIQ="PSODRG",DIQ(0)="I"
  D EN^DIQ1 S COST=PSODRG(50,DA,16,"I") K PSODRG,DIC,DA,DR,DIQ,DIR
- 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
- S REF=$S(Y:0,1:1)
- S X1=DT,X2=-485 D C^%DTC S (DEF,Y)=X X ^DD("DD")
+ 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
+ S REF=$S(Y:Y,1:0),X1=DT,X2=-485 D C^%DTC S (DEF,Y)=X X ^DD("DD")
  W !!,"You can only go back One Year plus 120 days."
- 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
- S (FBCK,%DT(0))=Y,%DT("A")="Enter ending fill date: " D ^%DT
+ 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
+ S (FBCK,%DT(0))=Y,%DT("A")="How far AHEAD do you want to go: " D ^%DT
  K %DT I Y<0!($D(DTOUT)) K FBCK,REF,COST,DRG,X,Y Q
- S FAHD=Y
- S PSOFUTR=0 I FAHD>(DT-1) S PSOFUTR=1 D
- .W !!,"Since you selected an end fill date of today or in the future, this option"
- .W !,"will update the cost for all existing and suspended fills that have a"
- .W !,"fill date in the future.",!
- 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
+ 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
  I Y S PSOQ=1 K ZTDTH D  G OUT
  .S ZTRTN="EN^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx Cost Update"
- .F G="REF","COST","DRG","FBCK","FAHD","PSOQ","PSOFUTR" S:$D(@G) ZTSAVE(G)=""
- .D ^%ZTLOAD I $D(ZTSK) W !!,"Rxs Cost Update Queued",! K ZTSK
-EN W:'$G(PSOQ) !,"Updating cost. Please wait... "
- S FDT=FBCK-1 F  S FDT=$O(^PSRX("ADL",FDT)) Q:'FDT  D  Q:FDT>FAHD
- .I '$G(PSOFUTR) I FDT>FAHD Q
- .S RXN=0 F  S RXN=$O(^PSRX("ADL",FDT,DRG,RXN)) Q:'RXN  D  W:'$G(PSOQ) "."
- ..I $P($G(^PSRX(RXN,0)),"^",6)=DRG,$P($G(^(2)),"^",2)=FDT S $P(^PSRX(RXN,0),"^",17)=COST
- I 'REF G OUT
- D REFILL,PARTIAL
-OUT K G,COST,I,X,Y,REF,RXN,FDT,FAHD,FBCK,DRG,PSOQ,DIRUT,PSOFUTR I $D(ZTQUEUED) S ZTREQ="@"
+ .F G="REF","COST","DRG","FBCK","FAHD","PSOQ" S:$D(@G) ZTSAVE(G)=""
+ .D ^%ZTLOAD I $D(ZTSK) W !,"Rxs Cost Update Queued" K ZTSK
+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) "."
+ .I $P($G(^PSRX(RXN,0)),"^",6)=DRG,$P($G(^(2)),"^",2)=FDT S $P(^PSRX(RXN,0),"^",17)=COST
+ .Q:'REF
+ .F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I  S $P(^PSRX(RXN,1,I,0),"^",11)=COST
+ .F I=0:0 S I=$O(^PSRX(RXN,"P",I)) Q:'I  S $P(^PSRX(RXN,"P",I,0),"^",11)=COST
+OUT K G,COST,I,X,Y,REF,RXN,FDT,FAHD,FBCK,DRG,PSOQ,DIRUT I $D(ZTQUEUED) S ZTREQ="@"
  Q
 POST ;post install entry point.  builds new "ADL" xref for file 52 pso*7*20
@@ -58 +47 @@
  K X,Y,DEF,FTY,IFN S ZTREQ="@"
  Q
-REFILL ;
- N FILL,FDT,RXN
- S FDT=FBCK-1 F  S FDT=$O(^PSRX("AD",FDT)) Q:'FDT  D  Q:FDT>FAHD
- .I '$G(PSOFUTR),FDT>FAHD Q
- .S RXN="" F  S RXN=$O(^PSRX("AD",FDT,RXN)) Q:'RXN  D
- ..I $P($G(^PSRX(RXN,0)),"^",6)'=DRG Q
- ..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
- Q
-PARTIAL ;
-  N FILL,FDT,RXN
-  S FDT=FBCK-1 F  S FDT=$O(^PSRX("ADP",FDT)) Q:'FDT  D  Q:FDT>FAHD
- .I '$G(PSOFUTR),FDT>FAHD Q
- .S RXN="" F  S RXN=$O(^PSRX("ADP",FDT,RXN)) Q:'RXN  D
- ..I $P($G(^PSRX(RXN,0)),"^",6)'=DRG Q
- ..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
- Q