PSOHELP3.m

PSOHELP3 ;BHAM ISC/SAB - outpatient utility routine #4 ;2/17/93 18:00:36

 ;;7.0;OUTPATIENT PHARMACY;**20,291**;DEC 1997;Build 2

XREF ;code to create 'APD' xref on Drug Interaction file (#56)

 ;I '$D(ZTSK),'$D(PSMSG) D WAIT^DICD W "Building 'APD' X-Ref."

 ;The following code accessing files 56 and 50.416 is no longer executed

 S ID1=$P(^PS(56,DA,0),"^",2),ID2=$P(^(0),"^",3),TOT=0

 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

 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

 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

 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

 S $P(^PS(56,DA,0),"^",6)=TOT

EX K TOT,I5,I6,D2,I4,I3,PRI,I1,I2,R2,PS1,PS2,ID2,ID1

 Q

SEC I +$G(DEL) K ^PS(56,"APD",R2,D2,DA),^PS(56,"APD",D2,R2,DA) Q

 S ^PS(56,"APD",R2,D2,DA)="",^PS(56,"APD",D2,R2,DA)="",TOT=TOT+2

 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 !!,"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

 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

 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="@"

 Q

POST ;post install entry point.  builds new "ADL" xref for file 52 pso*7*20

 S ZTRTN="EN1^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx XREF Update"

 S ZTDTH=$H D ^%ZTLOAD I $D(ZTSK) D BMES^XPDUTL(" Post Install Background Job Queued.") K ZTSK

 Q

EN1 K ^PSRX("ADL") S X1=DT,X2=-485 D C^%DTC S DEF=X-1 W !,"DEF: "_DEF

 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

 .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)=""

 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

PSOHELP3  ;BHAM ISC/SAB - outpatient utility routine #4 ;2/17/93 18:00:36

 +1       ;;7.0;OUTPATIENT PHARMACY;**20,291**;DEC 1997;Build 2

XREF      ;code to create 'APD' xref on Drug Interaction file (#56)

 +1       ;I '$D(ZTSK),'$D(PSMSG) D WAIT^DICD W "Building 'APD' X-Ref."

 +2       ;The following code accessing files 56 and 50.416 is no longer executed

 +3        SET ID1=$PIECE(^PS(56,DA,0),"^",2)

           SET ID2=$PIECE(^(0),"^",3)

           SET TOT=0

 +4        FOR I1=0:0

               SET I1=$ORDER(^PS(50.416,ID1,1,I1))

               IF 'I1

                   QUIT 

               SET R2=$PIECE(^(I1,0),"^")

               FOR I2=0:0

                   SET I2=$ORDER(^PS(50.416,ID2,1,I2))

                   IF 'I2

                       QUIT 

                   SET D2=$PIECE(^(I2,0),"^")

                   IF +$GET(PSMSG)

                       WRITE "."

                   DO SEC

 +5        FOR I1=0:0

               SET I1=$ORDER(^PS(50.416,"APS",ID1,I1))

               IF 'I1

                   QUIT 

               FOR I3=0:0

                   SET I3=$ORDER(^PS(50.416,I1,1,I3))

                   IF 'I3

                       QUIT 

                   SET R2=$PIECE(^(I3,0),"^")

                   FOR I5=0:0

                       SET I5=$ORDER(^PS(50.416,"APS",ID2,I5))

                       IF 'I5

                           QUIT 

                       FOR I6=0:0

                           SET I6=$ORDER(^PS(50.416,I5,1,I6))

                           IF 'I6

                               QUIT 

                           SET D2=$PIECE(^(I6,0),"^")

                           DO SEC

 +6        FOR I1=0:0

               SET I1=$ORDER(^PS(50.416,ID1,1,I1))

               IF 'I1

                   QUIT 

               SET R2=$PIECE(^(I1,0),"^")

               FOR I5=0:0

                   SET I5=$ORDER(^PS(50.416,"APS",ID2,I5))

                   IF 'I5

                       QUIT 

                   FOR I6=0:0

                       SET I6=$ORDER(^PS(50.416,I5,1,I6))

                       IF 'I6

                           QUIT 

                       SET D2=$PIECE(^(I6,0),"^")

                       DO SEC

 +7        FOR I2=0:0

               SET I2=$ORDER(^PS(50.416,ID2,1,I2))

               IF 'I2

                   QUIT 

               SET D2=$PIECE(^(I2,0),"^")

               FOR I1=0:0

                   SET I1=$ORDER(^PS(50.416,"APS",ID1,I1))

                   IF 'I1

                       QUIT 

                   FOR I3=0:0

                       SET I3=$ORDER(^PS(50.416,I1,1,I3))

                       IF 'I3

                           QUIT 

                       SET R2=$PIECE(^(I3,0),"^")

                       DO SEC

 +8        SET $PIECE(^PS(56,DA,0),"^",6)=TOT

EX         KILL TOT,I5,I6,D2,I4,I3,PRI,I1,I2,R2,PS1,PS2,ID2,ID1

 +1        QUIT 

SEC        IF +$GET(DEL)

               KILL ^PS(56,"APD",R2,D2,DA),^PS(56,"APD",D2,R2,DA)

               QUIT 

 +1        SET ^PS(56,"APD",R2,D2,DA)=""

           SET ^PS(56,"APD",D2,R2,DA)=""

           SET TOT=TOT+2

 +2        QUIT 

DRUG      ;selects drug and updates Rx file with cost (pso*7*20)

 +1        WRITE !!,"This option will update the drug cost on all fills in the PRESCRIPTION"

 +2        WRITE !,"file (#52) based on the selected date range and the current cost in the"

 +3        WRITE !,"DRUG file (#50).",!

 +4        KILL X,Y,DA,DIC

           SET DIC(0)="AQEM"

           SET DIC=50

           DO ^DIC

           IF $GET(DUOUT)

               KILL DIC,Y,X,DA

               QUIT 

 +5        IF Y<0

               GOTO OUT

 +6        SET (DRG,DA)=+Y

           KILL DIC,DR,DIQ

           SET DIC=50

           SET DR=16

           SET DIQ="PSODRG"

           SET DIQ(0)="I"

 +7        DO EN^DIQ1

           SET COST=PSODRG(50,DA,16,"I")

           KILL PSODRG,DIC,DA,DR,DIQ,DIR

 +8        WRITE !

           SET DIR("A")="Do you want to exclude Refills and Partials"

           SET DIR(0)="Y"

           SET DIR("B")="No"

           DO ^DIR

           KILL DIR

           IF $GET(DIRUT)

               KILL COST,X,DRG,Y

               QUIT 

 +9        SET REF=$SELECT(Y:0,1:1)

 +10       SET X1=DT

           SET X2=-485

           DO C^%DTC

           SET (DEF,Y)=X

           XECUTE ^DD("DD")

 +11       WRITE !!,"You can only go back One Year plus 120 days."

 +12       SET %DT(0)=DEF

           SET %DT="AQEX"

           SET %DT("A")="Enter starting fill date: "

           SET %DT("B")=Y

           DO ^%DT

           KILL %DT("B"),DEF

           IF Y<0!($DATA(DTOUT))

               KILL REF,COST,DRG,X,Y

               QUIT 

 +13       SET (FBCK,%DT(0))=Y

           SET %DT("A")="Enter ending fill date: "

           DO ^%DT

 +14       KILL %DT

           IF Y<0!($DATA(DTOUT))

               KILL FBCK,REF,COST,DRG,X,Y

               QUIT 

 +15       SET FAHD=Y

 +16       SET PSOFUTR=0

           IF FAHD>(DT-1)

               SET PSOFUTR=1

               Begin DoDot:1

 +17               WRITE !!,"Since you selected an end fill date of today or in the future, this option"

 +18               WRITE !,"will update the cost for all existing and suspended fills that have a"

 +19               WRITE !,"fill date in the future.",!

               End DoDot:1

 +20       KILL DIR,X,Y

           SET DIR(0)="Y"

           SET DIR("A")="Do you want to Queue to run at a specific Time"

           SET DIR("B")="Yes"

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               GOTO OUT

 +21       IF Y

               SET PSOQ=1

               KILL ZTDTH

               Begin DoDot:1

 +22               SET ZTRTN="EN^PSOHELP3"

                   SET ZTIO=""

                   SET ZTDESC="Outpatient Pharmacy Rx Cost Update"

 +23               FOR G="REF","COST","DRG","FBCK","FAHD","PSOQ","PSOFUTR"

                       IF $DATA(@G)

                           SET ZTSAVE(G)=""

 +24               DO ^%ZTLOAD

                   IF $DATA(ZTSK)

                       WRITE !!,"Rxs Cost Update Queued",!

                       KILL ZTSK

               End DoDot:1

               GOTO OUT

EN         IF '$GET(PSOQ)

               WRITE !,"Updating cost. Please wait... "

 +1        SET FDT=FBCK-1

           FOR 

               SET FDT=$ORDER(^PSRX("ADL",FDT))

               IF 'FDT

                   QUIT 

               Begin DoDot:1

 +2                IF '$GET(PSOFUTR)

                       IF FDT>FAHD

                           QUIT 

 +3                SET RXN=0

                   FOR 

                       SET RXN=$ORDER(^PSRX("ADL",FDT,DRG,RXN))

                       IF 'RXN

                           QUIT 

                       Begin DoDot:2

 +4                        IF $PIECE($GET(^PSRX(RXN,0)),"^",6)=DRG

                               IF $PIECE($GET(^(2)),"^",2)=FDT

                                   SET $PIECE(^PSRX(RXN,0),"^",17)=COST

                       End DoDot:2

                       IF '$GET(PSOQ)

                           WRITE "."

               End DoDot:1

               IF FDT>FAHD

                   QUIT 

 +5        IF 'REF

               GOTO OUT

 +6        DO REFILL

           DO PARTIAL

OUT        KILL G,COST,I,X,Y,REF,RXN,FDT,FAHD,FBCK,DRG,PSOQ,DIRUT,PSOFUTR

           IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +1        QUIT 

POST      ;post install entry point.  builds new "ADL" xref for file 52 pso*7*20

 +1        SET ZTRTN="EN1^PSOHELP3"

           SET ZTIO=""

           SET ZTDESC="Outpatient Pharmacy Rx XREF Update"

 +2        SET ZTDTH=$HOROLOG

           DO ^%ZTLOAD

           IF $DATA(ZTSK)

               DO BMES^XPDUTL(" Post Install Background Job Queued.")

               KILL ZTSK

 +3        QUIT 

EN1        KILL ^PSRX("ADL")

           SET X1=DT

           SET X2=-485

           DO C^%DTC

           SET DEF=X-1

           WRITE !,"DEF: "_DEF

 +1        FOR 

               SET DEF=$ORDER(^PSRX("AD",DEF))

               IF 'DEF

                   QUIT 

               FOR IFN=0:0

                   SET IFN=$ORDER(^PSRX("AD",DEF,IFN))

                   IF 'IFN

                       QUIT 

                   SET FTY=""

                   FOR 

                       SET FTY=$ORDER(^PSRX("AD",DEF,IFN,FTY))

                       IF FTY=""

                           QUIT 

                       IF FTY=0

                           Begin DoDot:1

 +2                            IF $PIECE($GET(^PSRX(IFN,2)),"^",2)

                                   IF $PIECE($GET(^(0)),"^",6)

                                       SET ^PSRX("ADL",$PIECE($GET(^PSRX(IFN,2)),"^",2),$PIECE($GET(^(0)),"^",6),IFN)=""

                           End DoDot:1

 +3        KILL X,Y,DEF,FTY,IFN

           SET ZTREQ="@"

 +4        QUIT 

REFILL    ;

 +1        NEW FILL,FDT,RXN

 +2        SET FDT=FBCK-1

           FOR 

               SET FDT=$ORDER(^PSRX("AD",FDT))

               IF 'FDT

                   QUIT 

               Begin DoDot:1

 +3                IF '$GET(PSOFUTR)

                       IF FDT>FAHD

                           QUIT 

 +4                SET RXN=""

                   FOR 

                       SET RXN=$ORDER(^PSRX("AD",FDT,RXN))

                       IF 'RXN

                           QUIT 

                       Begin DoDot:2

 +5                        IF $PIECE($GET(^PSRX(RXN,0)),"^",6)'=DRG

                               QUIT 

 +6                        SET FILL=0

                           FOR 

                               SET FILL=$ORDER(^PSRX("AD",FDT,RXN,FILL))

                               IF 'FILL

                                   QUIT 

                               IF $DATA(^PSRX(RXN,1,FILL,0))

                                   SET $PIECE(^(0),"^",11)=COST

                       End DoDot:2

               End DoDot:1

               IF FDT>FAHD

                   QUIT 

 +7        QUIT 

PARTIAL   ;

 +1        NEW FILL,FDT,RXN

 +2        SET FDT=FBCK-1

           FOR 

               SET FDT=$ORDER(^PSRX("ADP",FDT))

               IF 'FDT

                   QUIT 

               Begin DoDot:1

 +3                IF '$GET(PSOFUTR)

                       IF FDT>FAHD

                           QUIT 

 +4                SET RXN=""

                   FOR 

                       SET RXN=$ORDER(^PSRX("ADP",FDT,RXN))

                       IF 'RXN

                           QUIT 

                       Begin DoDot:2

 +5                        IF $PIECE($GET(^PSRX(RXN,0)),"^",6)'=DRG

                               QUIT 

 +6                        SET FILL=0

                           FOR 

                               SET FILL=$ORDER(^PSRX("ADP",FDT,RXN,FILL))

                               IF 'FILL

                                   QUIT 

                               IF $DATA(^PSRX(RXN,"P",FILL,0))

                                   SET $PIECE(^(0),"^",11)=COST

                       End DoDot:2

               End DoDot:1

               IF FDT>FAHD

                   QUIT 

 +7        QUIT