- 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 Jan 18, 2025@02:51:04 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