PSOHELP3 ;BHAM ISC/SAB - outpatient utility routine #4 ;2/17/93 18:00:36
;;7.0;OUTPATIENT PHARMACY;**20,291,422**;DEC 1997;Build 132
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
INSCHK(PSOINS) ;CHECK PATIENT INSTRUCTIONS/OTHER PATIENT INSTRUCTIONS ;*422
I '$P($G(^PS(55,PSODFN,"LAN")),"^") Q 0
I $G(PSOINS("DFLG")) Q 0
I $G(PSOINS("INS"))]"",$G(PSOINS("SINS"))="" W $C(7),!!?5,"OTHER PATIENT INSTRUCTIONS REQUIRED",! Q 2
I $G(PSOINS("INS"))="",$G(PSOINS("SINS"))]"" W $C(7),!!?5,"PATIENT INSTRUCTIONS REQUIRED",! Q 1
Q 0
DELINS ;IF DELETE PATIENT INSTRUCTIONS OR OTHER PATIENT INSTRUCTIONS, NOTIFY USER BOTH WILL BE DELETED, PROMPT IF OKAY ; *422
I '$P($G(^PS(55,PSODFN,"LAN")),"^") Q
N X,Y,DIR,DIRUT
W $C(7),!!?5,"ANY DATA ENTERED FOR "_$S($G(PSODELINS)=1:"OTHER PATIENT INSTRUCTIONS",1:"PATIENT INSTRUCTIONS")
W $C(7),!?5,"WILL ALSO BE DELETED.",!
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Continue with Deletion" D ^DIR
I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S X="NO",Y=0 ;IF ^ OR TIMEOUT TREAT AS IF ANSWERED NO
S (PSODELINS,PSODONE)=Y
K DIR,DIRUT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHELP3 5660 printed Sep 23, 2025@20:06:03 Page 2
PSOHELP3 ;BHAM ISC/SAB - outpatient utility routine #4 ;2/17/93 18:00:36
+1 ;;7.0;OUTPATIENT PHARMACY;**20,291,422**;DEC 1997;Build 132
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
INSCHK(PSOINS) ;CHECK PATIENT INSTRUCTIONS/OTHER PATIENT INSTRUCTIONS ;*422
+1 IF '$PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
QUIT 0
+2 IF $GET(PSOINS("DFLG"))
QUIT 0
+3 IF $GET(PSOINS("INS"))]""
IF $GET(PSOINS("SINS"))=""
WRITE $CHAR(7),!!?5,"OTHER PATIENT INSTRUCTIONS REQUIRED",!
QUIT 2
+4 IF $GET(PSOINS("INS"))=""
IF $GET(PSOINS("SINS"))]""
WRITE $CHAR(7),!!?5,"PATIENT INSTRUCTIONS REQUIRED",!
QUIT 1
+5 QUIT 0
DELINS ;IF DELETE PATIENT INSTRUCTIONS OR OTHER PATIENT INSTRUCTIONS, NOTIFY USER BOTH WILL BE DELETED, PROMPT IF OKAY ; *422
+1 IF '$PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
QUIT
+2 NEW X,Y,DIR,DIRUT
+3 WRITE $CHAR(7),!!?5,"ANY DATA ENTERED FOR "_$SELECT($GET(PSODELINS)=1:"OTHER PATIENT INSTRUCTIONS",1:"PATIENT INSTRUCTIONS")
+4 WRITE $CHAR(7),!?5,"WILL ALSO BE DELETED.",!
+5 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Continue with Deletion"
DO ^DIR
+6 ;IF ^ OR TIMEOUT TREAT AS IF ANSWERED NO
IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIROUT))
SET X="NO"
SET Y=0
+7 SET (PSODELINS,PSODONE)=Y
+8 KILL DIR,DIRUT
+9 QUIT
