PSAOP2 ;BIR/LTL-Outpatient Dispensing (All Drugs) ;7/23/97
;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,15,76**; 10/24/97;Build 1
;This routine gathers outpatient dispensing for all drugs in a location
;from the PRESCRIPTION file. If present, the last outpatient dispensing
;date is used as a starting point. Otherwise the user selected date is
;used.
;
;References to ^PSDRUG( are covered by IA #2095
;References to ^PSRX( are covered by IA #254
;
D PSAWARN^PSAPSI I $D(PSAQUIT) K PSAQUIT Q
D Q
S $P(PSALN,"-",79)="-"
LOOK D OP^PSADA
G:'$G(PSALOC) Q W !,$G(PSALOCN)
S DIR(0)="Y",DIR("A")="OK",DIR("B")="Yes",DIR("?")="Answering no will allow you to change Location." D ^DIR K DIR S:$D(DIRUT) PSAOUT=1 G:$D(DIRUT) Q I Y=0 K PSALOC D OP^PSADA G:'$G(PSALOC) Q
I '$O(^PSD(58.8,+PSALOC,1,0)) W !!,"There are no drugs in ",PSALOCN,!! G Q
D NOW^%DTC S PSADT=X,X="T-6000" D ^%DT S PSADT(1)=Y,(PSAPG,PSAOUT,PSADRUG)=0
S DIR(0)="D^"_PSADT(1)_":"_PSADT_":AEX",DIR("A")="How far back would you like to collect",DIR("B")="T-6000" D ^DIR K DIR S (PSADT(2),PSADT(22),PSAR,PSAP,PSAN)=Y,(PSADT(3),PSAR(1),PSAP(1),PSAN(1))=0 I Y<1 S PSAOUT=1 Q
S (PSAOP,PSAS)=$P($G(^PSD(58.8,+PSALOC,0)),U,10)
S DIR(0)="Y",DIR("A")="Would you like a report of daily dispensing totals",DIR("B")="Yes" D ^DIR K DIR S:$D(DIRUT) PSAOUT=1 G:$D(DIRUT) STOP
I Y=1 S PSADAILY=1
DEV K IO("Q") K %ZIS,IOP,POP S %ZIS="Q" I Y=1 W ! D ^%ZIS
I $G(POP) W !,"NO DEVICE SELECTED OR ACTION TAKEN!" S PSAOUT=1 G Q
I $D(IO("Q")) K ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK S ZTRTN="LUP^PSAOP2",ZTDESC="Drug Acct-Daily Drug Dispensing Log",ZTSAVE("PSA*")="" D ^%ZTLOAD G Q
;
LUP ;Starting point
S PSADRUG=0 W @IOF
PROCESS F PSAHOW="AL","AJ","AM","AN" S PSADT=PSADT(22)-.00001 D LOOP
G DONE
;
LOOP ;
I $E(IOST)="C" W !,"Processing ",$S(PSAHOW="AL":"dispensing",PSAHOW="AJ":"returns",PSAHOW="AM":"partials",1:"returns")
;
1 S PSADT=$O(^PSRX(PSAHOW,PSADT)) Q:PSADT'>0 K PSAIEN
2 S PSAIEN=$S('$D(PSAIEN):$O(^PSRX(PSAHOW,PSADT,0)),1:$O(^PSRX(PSAHOW,PSADT,PSAIEN))) G 1:PSAIEN'>0 K PSARX
3 S PSARX=$S('$D(PSARX):$O(^PSRX(PSAHOW,PSADT,PSAIEN,"")),1:$O(^PSRX(PSAHOW,PSADT,PSAIEN,PSARX))) G 2:PSARX="" W "."
I $D(^PSRX("AR",PSADT,PSAIEN,PSARX)) G 3
S PSADRUG=$P($G(^PSRX(PSAIEN,0)),"^",6) I $G(PSADRUG)="" G 3
S PSADRUGN=$P($G(^PSDRUG(PSADRUG,0)),"^")
I '$D(^PSD(58.8,PSALOC,1,PSADRUG)) G 3
I $P($G(^PSRX(PSAIEN,2)),"^",9)'=PSAS G 3
;
S PSAQTY=$S(+PSARX:$P($G(^PSRX(PSAIEN,1,PSARX,0)),"^",4),1:$P($G(^PSRX(PSAIEN,0)),"^",7)) ;either refill or fill
;
I '$D(^TMP("PSA",$J,PSADRUGN,$E(PSADT,1,7))) S ^TMP("PSA",$J,PSADRUGN,$E(PSADT,1,7))=""
S DATA=^TMP("PSA",$J,PSADRUGN,$E(PSADT,1,7))
S $P(^TMP("PSA",$J,PSADRUGN,$E(PSADT,1,7)),"^",1)=$S(PSAHOW="AL":$P(DATA,"^")+PSAQTY,PSAHOW="AJ":$P(DATA,"^")-PSAQTY,PSAHOW="AM":$P(DATA,"^")+$P($G(^PSRX(PSAIEN,"P",PSARX,0)),"^",4),1:$P(DATA,"^")-$P($G(^PSRX(PSAIEN,"P",PSARX,0)),"^",4))
;
S $P(^TMP("PSA",$J,PSADRUGN,$E(PSADT,1,7)),"^",$S(PSAHOW="AL":2,PSAHOW="AJ":4,PSAHOW="AM":6,1:8))=PSAIEN
S $P(^TMP("PSA",$J,PSADRUGN,$E(PSADT,1,7)),"^",$S(PSAHOW="AL":3,PSAHOW="AJ":5,PSAHOW="AM":7,1:9))=PSARX
G 3
;
DONE ;All dispensing data retrieved, print it.
D HEADER
S XX=0 F S XX=$O(^PSD(58.88,PSALOC,1,XX)) Q:XX'>0 S XXX=$P($G(^PSDRUG,XX),"^") I '$D(^TMP("PSA",$J,XXX)) S ^TMP("PSA",$J,XXX)=0
S PSADRUGN=0
4 S PSADRUGN=$O(^TMP("PSA",$J,PSADRUGN)) G STOP:PSADRUGN=""
S PSADRUG=$O(^PSDRUG("B",PSADRUGN,0))
I $Y>(IOSL+4) D HEADER G Q:$G(PSAOUT)=1
I '$D(^TMP("PSA",$J,PSADRUGN)) W !,PSADRUGN,?36,"has not been dispensed since: " S Y=$S($P($G(^PSD(58.8,PSALOC,1,PSADRUG,6)),"^"):$P(^PSD(58.8,PSALOC,1,PSADRUG,6),"^"),1:PSADT(22)) X ^DD("DD") W Y,"." G 4
W !,PSADRUGN
K PNTDATA,PSADATE,PSATTLP,DAYS
5 S PSADATE=$S('$D(PSADATE):$O(^TMP("PSA",$J,PSADRUGN,0)),1:$O(^TMP("PSA",$J,PSADRUGN,PSADATE))) G PNTQ:PSADATE'>0 S DATA=^TMP("PSA",$J,PSADRUGN,PSADATE) S DAYS=$G(DAYS)+1
S Y=PSADATE X ^DD("DD") S PRINTDT=Y
S PSAQTY=$P(DATA,"^")
;
S PSAPRICE=$P($G(^PSDRUG(PSADRUG,660)),"^",6) ;Price per dispense Unit
S PSADISPU=$P($G(^PSDRUG(PSADRUG,660)),"^",8) ;Dispense Unit
;
S Y=PSAQTY,X2=0 D COMMA^%DTC S PNTQTY=Y
S TTLQTY=$G(TTLQTY)+PSAQTY ;total quantity
S PSAPRICE(2)=$G(PSAPRICE(2))+(PSAPRICE*PSAQTY) ;Total Cost
S Y=PSAPRICE,X2="3$" D COMMA^%DTC S PNTPRICE=Y
S Y=PSAPRICE*PSAQTY,X2="3$" D COMMA^%DTC S PSAQP=Y
I $D(PSADAILY) W !,$G(DAYS),?3,PRINTDT,?23,PNTQTY,?40,PNTPRICE,"/",PSADISPU,?63,PSAQP K PSAQP G 5
G 5
;
PNTQ W !,PSALN,!,DAYS," DAY TOTALS: " S Y=TTLQTY,X2="2$" D COMMA^%DTC W Y S Y=PSAPRICE(2),X2="2$" D COMMA^%DTC W ?63,Y
K TTLQTY,PSAPRICE,PSAQTY,PNTQTY
G 4
;
I $$S^%ZTLOAD S PSAOUT=1 Q
W:$Y @IOF S PSAPG=$G(PSAPG)+1 W ?2,"DAILY DISPENSING TOTALS FOR ",$E($G(PSALOCN),1,30),?70,"PAGE: ",PSAPG,!,PSALN,!
W " DATE",?23,"TOTAL",?45,"$/DISP",?67,"TOTAL",!," DISPENSED",?23,"DISP",?46,"UNIT",?68,"COST",!,PSALN
Q
Q D ^%ZISC K PNTDATA,PNTDATE,PNTPRICE,PNTQTY,POP,PRINTDT,PSA,PSADAILY,PSADATE,PDADISPU,PSADR,PSADREC,PSADRUG,PSACNT,PSAPG,PSAOSIT
K PSADRUGN,PSADT,PSAG,PSAHOW,PSAIEN,PSALN,PSALOC,PSALOCN,PSAN,PSAOP,PSAOUT,PSAP,PSAPRICE,PSAQ,PSAQTY,PSAR,PSAREC,PSARELDT,PSARX,PSAS,PSAT,PSATTLP,TTLQTY,^TMP("PSA",$J),^TMP($J)
Q
STOP W:$E(IOST)'="C" @IOF
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q")
I $D(^TMP("PSA",$J)) D
.W !!,"Updating history and dispensing totals."
.D ^PSAOP4
G Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAOP2 5502 printed Sep 23, 2025@19:25:53 Page 2
PSAOP2 ;BIR/LTL-Outpatient Dispensing (All Drugs) ;7/23/97
+1 ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,15,76**; 10/24/97;Build 1
+2 ;This routine gathers outpatient dispensing for all drugs in a location
+3 ;from the PRESCRIPTION file. If present, the last outpatient dispensing
+4 ;date is used as a starting point. Otherwise the user selected date is
+5 ;used.
+6 ;
+7 ;References to ^PSDRUG( are covered by IA #2095
+8 ;References to ^PSRX( are covered by IA #254
+9 ;
+10 DO PSAWARN^PSAPSI
IF $DATA(PSAQUIT)
KILL PSAQUIT
QUIT
+11 DO Q
+12 SET $PIECE(PSALN,"-",79)="-"
LOOK DO OP^PSADA
+1 if '$GET(PSALOC)
GOTO Q
WRITE !,$GET(PSALOCN)
+2 SET DIR(0)="Y"
SET DIR("A")="OK"
SET DIR("B")="Yes"
SET DIR("?")="Answering no will allow you to change Location."
DO ^DIR
KILL DIR
if $DATA(DIRUT)
SET PSAOUT=1
if $DATA(DIRUT)
GOTO Q
IF Y=0
KILL PSALOC
DO OP^PSADA
if '$GET(PSALOC)
GOTO Q
+3 IF '$ORDER(^PSD(58.8,+PSALOC,1,0))
WRITE !!,"There are no drugs in ",PSALOCN,!!
GOTO Q
+4 DO NOW^%DTC
SET PSADT=X
SET X="T-6000"
DO ^%DT
SET PSADT(1)=Y
SET (PSAPG,PSAOUT,PSADRUG)=0
+5 SET DIR(0)="D^"_PSADT(1)_":"_PSADT_":AEX"
SET DIR("A")="How far back would you like to collect"
SET DIR("B")="T-6000"
DO ^DIR
KILL DIR
SET (PSADT(2),PSADT(22),PSAR,PSAP,PSAN)=Y
SET (PSADT(3),PSAR(1),PSAP(1),PSAN(1))=0
IF Y<1
SET PSAOUT=1
QUIT
+6 SET (PSAOP,PSAS)=$PIECE($GET(^PSD(58.8,+PSALOC,0)),U,10)
+7 SET DIR(0)="Y"
SET DIR("A")="Would you like a report of daily dispensing totals"
SET DIR("B")="Yes"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
SET PSAOUT=1
if $DATA(DIRUT)
GOTO STOP
+8 IF Y=1
SET PSADAILY=1
DEV KILL IO("Q")
KILL %ZIS,IOP,POP
SET %ZIS="Q"
IF Y=1
WRITE !
DO ^%ZIS
+1 IF $GET(POP)
WRITE !,"NO DEVICE SELECTED OR ACTION TAKEN!"
SET PSAOUT=1
GOTO Q
+2 IF $DATA(IO("Q"))
KILL ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
SET ZTRTN="LUP^PSAOP2"
SET ZTDESC="Drug Acct-Daily Drug Dispensing Log"
SET ZTSAVE("PSA*")=""
DO ^%ZTLOAD
GOTO Q
+3 ;
LUP ;Starting point
+1 SET PSADRUG=0
WRITE @IOF
PROCESS FOR PSAHOW="AL","AJ","AM","AN"
SET PSADT=PSADT(22)-.00001
DO LOOP
+1 GOTO DONE
+2 ;
LOOP ;
+1 IF $EXTRACT(IOST)="C"
WRITE !,"Processing ",$SELECT(PSAHOW="AL":"dispensing",PSAHOW="AJ":"returns",PSAHOW="AM":"partials",1:"returns")
+2 ;
1 SET PSADT=$ORDER(^PSRX(PSAHOW,PSADT))
if PSADT'>0
QUIT
KILL PSAIEN
2 SET PSAIEN=$SELECT('$DATA(PSAIEN):$ORDER(^PSRX(PSAHOW,PSADT,0)),1:$ORDER(^PSRX(PSAHOW,PSADT,PSAIEN)))
if PSAIEN'>0
GOTO 1
KILL PSARX
3 SET PSARX=$SELECT('$DATA(PSARX):$ORDER(^PSRX(PSAHOW,PSADT,PSAIEN,"")),1:$ORDER(^PSRX(PSAHOW,PSADT,PSAIEN,PSARX)))
if PSARX=""
GOTO 2
WRITE "."
+1 IF $DATA(^PSRX("AR",PSADT,PSAIEN,PSARX))
GOTO 3
+2 SET PSADRUG=$PIECE($GET(^PSRX(PSAIEN,0)),"^",6)
IF $GET(PSADRUG)=""
GOTO 3
+3 SET PSADRUGN=$PIECE($GET(^PSDRUG(PSADRUG,0)),"^")
+4 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRUG))
GOTO 3
+5 IF $PIECE($GET(^PSRX(PSAIEN,2)),"^",9)'=PSAS
GOTO 3
+6 ;
+7 ;either refill or fill
SET PSAQTY=$SELECT(+PSARX:$PIECE($GET(^PSRX(PSAIEN,1,PSARX,0)),"^",4),1:$PIECE($GET(^PSRX(PSAIEN,0)),"^",7))
+8 ;
+9 IF '$DATA(^TMP("PSA",$JOB,PSADRUGN,$EXTRACT(PSADT,1,7)))
SET ^TMP("PSA",$JOB,PSADRUGN,$EXTRACT(PSADT,1,7))=""
+10 SET DATA=^TMP("PSA",$JOB,PSADRUGN,$EXTRACT(PSADT,1,7))
+11 SET $PIECE(^TMP("PSA",$JOB,PSADRUGN,$EXTRACT(PSADT,1,7)),"^",1)=...
... $SELECT(PSAHOW="AL":$PIECE(DATA,"^")+PSAQTY,PSAHOW="AJ":$PIECE(DATA,"^")-PSAQTY,PSAHOW="AM":$PIECE(DATA,"^")+$PIECE($GET(^PSRX(PSAIEN,"P",PSARX,0)),"^",4),1:$PIECE(DATA,"^")-$PIECE($GET(^PSRX(PSAIEN,"P",PSARX,0)),"^",4))
+12 ;
+13 SET $PIECE(^TMP("PSA",$JOB,PSADRUGN,$EXTRACT(PSADT,1,7)),"^",$SELECT(PSAHOW="AL":2,PSAHOW="AJ":4,PSAHOW="AM":6,1:8))=PSAIEN
+14 SET $PIECE(^TMP("PSA",$JOB,PSADRUGN,$EXTRACT(PSADT,1,7)),"^",$SELECT(PSAHOW="AL":3,PSAHOW="AJ":5,PSAHOW="AM":7,1:9))=PSARX
+15 GOTO 3
+16 ;
DONE ;All dispensing data retrieved, print it.
+1 DO HEADER
+2 SET XX=0
FOR
SET XX=$ORDER(^PSD(58.88,PSALOC,1,XX))
if XX'>0
QUIT
SET XXX=$PIECE($GET(^PSDRUG,XX),"^")
IF '$DATA(^TMP("PSA",$JOB,XXX))
SET ^TMP("PSA",$JOB,XXX)=0
+3 SET PSADRUGN=0
4 SET PSADRUGN=$ORDER(^TMP("PSA",$JOB,PSADRUGN))
if PSADRUGN=""
GOTO STOP
+1 SET PSADRUG=$ORDER(^PSDRUG("B",PSADRUGN,0))
+2 IF $Y>(IOSL+4)
DO HEADER
if $GET(PSAOUT)=1
GOTO Q
+3 IF '$DATA(^TMP("PSA",$JOB,PSADRUGN))
WRITE !,PSADRUGN,?36,"has not been dispensed since: "
SET Y=$SELECT($PIECE($GET(^PSD(58.8,PSALOC,1,PSADRUG,6)),"^"):$PIECE(^PSD(58.8,PSALOC,1,PSADRUG,6),"^"),1:PSADT(22))
XECUTE ^DD("DD")
WRITE Y,"."
GOTO 4
+4 WRITE !,PSADRUGN
+5 KILL PNTDATA,PSADATE,PSATTLP,DAYS
5 SET PSADATE=$SELECT('$DATA(PSADATE):$ORDER(^TMP("PSA",$JOB,PSADRUGN,0)),1:$ORDER(^TMP("PSA",$JOB,PSADRUGN,PSADATE)))
if PSADATE'>0
GOTO PNTQ
SET DATA=^TMP("PSA",$JOB,PSADRUGN,PSADATE)
SET DAYS=$GET(DAYS)+1
+1 SET Y=PSADATE
XECUTE ^DD("DD")
SET PRINTDT=Y
+2 SET PSAQTY=$PIECE(DATA,"^")
+3 ;
+4 ;Price per dispense Unit
SET PSAPRICE=$PIECE($GET(^PSDRUG(PSADRUG,660)),"^",6)
+5 ;Dispense Unit
SET PSADISPU=$PIECE($GET(^PSDRUG(PSADRUG,660)),"^",8)
+6 ;
+7 SET Y=PSAQTY
SET X2=0
DO COMMA^%DTC
SET PNTQTY=Y
+8 ;total quantity
SET TTLQTY=$GET(TTLQTY)+PSAQTY
+9 ;Total Cost
SET PSAPRICE(2)=$GET(PSAPRICE(2))+(PSAPRICE*PSAQTY)
+10 SET Y=PSAPRICE
SET X2="3$"
DO COMMA^%DTC
SET PNTPRICE=Y
+11 SET Y=PSAPRICE*PSAQTY
SET X2="3$"
DO COMMA^%DTC
SET PSAQP=Y
+12 IF $DATA(PSADAILY)
WRITE !,$GET(DAYS),?3,PRINTDT,?23,PNTQTY,?40,PNTPRICE,"/",PSADISPU,?63,PSAQP
KILL PSAQP
GOTO 5
+13 GOTO 5
+14 ;
PNTQ WRITE !,PSALN,!,DAYS," DAY TOTALS: "
SET Y=TTLQTY
SET X2="2$"
DO COMMA^%DTC
WRITE Y
SET Y=PSAPRICE(2)
SET X2="2$"
DO COMMA^%DTC
WRITE ?63,Y
+1 KILL TTLQTY,PSAPRICE,PSAQTY,PNTQTY
+2 GOTO 4
+3 ;
IF $GET(PSAPG)
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF '+Y
SET PSAOUT=1
QUIT
+1 IF $$S^%ZTLOAD
SET PSAOUT=1
QUIT
+2 if $Y
WRITE @IOF
SET PSAPG=$GET(PSAPG)+1
WRITE ?2,"DAILY DISPENSING TOTALS FOR ",$EXTRACT($GET(PSALOCN),1,30),?70,"PAGE: ",PSAPG,!,PSALN,!
+3 WRITE " DATE",?23,"TOTAL",?45,"$/DISP",?67,"TOTAL",!," DISPENSED",?23,"DISP",?46,"UNIT",?68,"COST",!,PSALN
+4 QUIT
Q DO ^%ZISC
KILL PNTDATA,PNTDATE,PNTPRICE,PNTQTY,POP,PRINTDT,PSA,PSADAILY,PSADATE,PDADISPU,PSADR,PSADREC,PSADRUG,PSACNT,PSAPG,PSAOSIT
+1 KILL PSADRUGN,PSADT,PSAG,PSAHOW,PSAIEN,PSALN,PSALOC,PSALOCN,PSAN,PSAOP,PSAOUT,PSAP,PSAPRICE,PSAQ,PSAQTY,PSAR,PSAREC,PSARELDT,PSARX,PSAS,PSAT,PSATTLP,TTLQTY,^TMP("PSA",$JOB),^TMP($JOB)
+2 QUIT
STOP if $EXTRACT(IOST)'="C"
WRITE @IOF
+1 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL IO("Q")
+2 IF $DATA(^TMP("PSA",$JOB))
Begin DoDot:1
+3 WRITE !!,"Updating history and dispensing totals."
+4 DO ^PSAOP4
End DoDot:1
+5 GOTO Q
