PSDPAT1 ;B'ham ISC/JPW,BJW - Prt activity report (Patient/Drug) ; 17 Apr 98
;;3.0; CONTROLLED SUBSTANCES ;**7,62**;13 Feb 97;Build 3
;modified for nois:det-0198-42285;displays drugs for destruction,returns,waste,transfers
START ;entry for compile and print
K ^TMP("PSDPAT",$J) S (AQTY,CNT)=0
I $D(ALL) F PSDR=0:0 S PSDR=$O(^PSD(58.8,+NAOU,1,PSDR)) Q:'PSDR I $D(^PSD(58.8,+NAOU,1,+PSDR,0)) S PSDRG(+PSDR)=+$P(^(0),"^",4)
F PSDR=0:0 S PSDR=$O(PSDRG(PSDR)) Q:'PSDR F PSD=PSDSD:0 S PSD=$O(^PSD(58.81,"ACT",PSD)) Q:'PSD!(PSD>PSDED) D
.F TYP=0:0 S TYP=$O(^PSD(58.81,"ACT",PSD,+NAOU,PSDR,TYP)) Q:'TYP F PSDA=0:0 S PSDA=$O(^PSD(58.81,"ACT",PSD,+NAOU,PSDR,TYP,PSDA)) Q:'PSDA D SET
;; *62 RJS>
F PSDR=0:0 S PSDR=$O(PSDRG(PSDR)) Q:'PSDR F PSDA=0:0 S PSDA=$O(^PSD(58.8,+NAOU,1,PSDR,3,PSDA)) Q:'PSDA D
.Q:'$D(^PSD(58.8,NAOU,1,PSDR,3,PSDA,0)) S NODE=^(0),PSD=$P(NODE,"^",15)
.I (PSD>PSDSD),(PSD<PSDED) D
..S NUR1=+$P(NODE,"^",7),NUR2="",QTY=+$P(NODE,"^",20),PAT="PHARMACY DISP #"_$P(NODE,U,16),PSDRN=$S($P($G(^PSDRUG(+PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR_" NAME MISSING") S PSDTR=+$P($G(NODE),"^",17)
..I (TYP=18)!(TYP=17) S $P(PSDRG(+PSDR),"^",2)=+$P(PSDRG(+PSDR),"^",2)+QTY
..S NUR1=$S($P($G(^VA(200,NUR1,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
..S (WQTY,WREAS,RQTY,RREAS,DRUGNO,SOQTY,DQTY,DREAS,PSDRET,DDATE)=""
..S NODE9="",$P(NODE,U,16)="",TYP=0
..S $P(NODE,U,10)=$P(NODE,U,22) D SET1
;; *62 RJS>
F PSD=PSDSD:0 S PSD=$O(^PSD(58.81,"ATRN",PSD)) Q:'PSD!(PSD>PSDED) D
.F PSDA=0:0 S PSDA=$O(^PSD(58.81,"ATRN",PSD,PSDA)) Q:'PSDA D
..S NODE=^PSD(58.81,PSDA,0) Q:$P(NODE,U,18)'=NAOU!('$D(PSDRG($P(NODE,U,5)))) D SET2
;; <*62 RJS
F S PSDR=$O(PSDRG(PSDR)) Q:'PSDR I $G(PSDRG(PSDR)) S PSDRN=$S($P($G(^PSDRUG(+PSDR,0)),U)]"":$P(^(0),U),1:"ZZ/"_PSDR_" NAME MISSING") D:'$D(^TMP("PSDPAT",$J,PSDRN))
.S ^TMP("PSDPAT",$J,PSDRN,DT,"NO ACTIVITY",1)=0
.S ^TMP("PSDPATL",$J,PSDRN)=U_PSDRG(PSDR)
PRINT ;prints data
I SUM="S" D ^PSDPAT2 G DONE
S (PG,PSDOUT,AQTY)=0,PSDRN="",$P(LN,"-",132)="" D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S RPDT=Y
I '$D(^TMP("PSDPAT",$J)) D HDR W !!,?15,"**** NO DISPENSING ACTIVITY ****",!! G DONE
D HDR S PSDRG="" F S PSDRG=$O(^TMP("PSDPAT",$J,PSDRG)) Q:PSDRG=""!(PSDOUT) W !,?5,"=> ",PSDRG,! D CHK F PSD=0:0 S PSD=$O(^TMP("PSDPAT",$J,PSDRG,PSD)) D:'PSD TOT Q:PSD=""!(PSDOUT) D Q:PSDOUT
.S PAT="" F S PAT=$O(^TMP("PSDPAT",$J,PSDRG,PSD,PAT)) Q:PAT=""!(PSDOUT) F PSD1=0:0 S PSD1=$O(^TMP("PSDPAT",$J,PSDRG,PSD,PAT,PSD1)) Q:'PSD1!(PSDOUT) D Q:PSDOUT
..S (QTY,SOQTY,RQTY,WQTY,DQTY,NEWBAL,ORDST)=0,(RREAS,WREAS,DREAS)=""
..S NODE=^TMP("PSDPAT",$J,PSDRG,PSD,PAT,PSD1),PSDRGN=PSDRG
..Q:$P(NODE,U,4)=3
..W !
..I $Y+8>IOSL D HDR Q:PSDOUT W !,?5,"=> ",PSDRG,!
..S Y=+$E(PSD,1,12) X ^DD("DD") S DATE=Y
..S TYP=+$P(NODE,"^",4),PSDR=$P(NODE,"^",11),ORDST=+$P(NODE,"^",24)
..S QTY=+$P(NODE,"^")
..I (TYP)=9 S PQTY=+$P(NODE,U,7)+QTY,NEWBAL=PQTY W DATE,?22,PAT,?55,$J(QTY,6),?75,$J(PQTY,6),?98,$P(NODE,U,2),!,?98,$P(NODE,U,3),!,?25,$P(NODE,U,6),!
..I TYP=11 S PQTY=+$P(NODE,U,7)+QTY,NEWBAL=PQTY W DATE,?22,PAT,?55,$J(QTY,6),?75,$J(PQTY,6),?98,$P(NODE,U,2),!,?98,$P(NODE,U,3),!
..I TYP=17 S SOQTY=+$P(NODE,"^",12),NEWBAL=+$P(NODE,"^",7)-SOQTY D
...W DATE,?22,PAT,?54 W:TYP=17 "-" W $J(SOQTY,6)
...W ?75,$J(NEWBAL,6),?98,$P(NODE,"^",2),!,?98,$P(NODE,"^",3),!
..I (TYP=17),(+$P(NODE,"^",9)) S RQTY=+$P(NODE,"^",9) D
...S RREAS=$P(NODE,"^",10),NEWBAL=+NEWBAL+RQTY,PSDRET=$P(NODE,"^",15),Y=PSDRET X ^DD("DD") S PSDRET=$E(Y,1,17)
...S:$G(PSDRET)=0 PSDRET="" W PSDRET,?22,PAT,?45,"*RETURN*",?55,$J(RQTY,6),?75,$J(NEWBAL,6),?98,$P(NODE,"^",2),!,?25,RREAS,?98,$P(NODE,"^",3),!
..I +$P(NODE,U,5) S WQTY=+$P(NODE,U,5),WREAS=$P(NODE,"^",6),QTY=QTY-WQTY D
...W DATE,?22,PAT,?45,"*WASTED*",?55,$J(WQTY,6)
...W ?98,$P(NODE,"^",2),!,?25,WREAS,?98,$P(NODE,"^",3),!
..I +$P(NODE,U,13) S DQTY=+$P(NODE,U,13),DREAS=$P(NODE,U,14),DDATE=+$P(NODE,U,16) D
...W DATE,?22,PAT,?45,"*DESTROY*",?55,$J(DQTY,6),?98,$P(NODE,"^",2),!,?25,DREAS,?98,$P(NODE,"^",3),!
..W:TYP=17 DATE,?22,PAT,?45,"*GIVEN*",?55,$J(QTY,6),!
..I TYP=23 S PQTY=+$P(NODE,U,7)+QTY,NEWBAL=PQTY W DATE,?22,PAT,?55,$J(QTY,6),?75,$J(PQTY,6),?98,$P(NODE,U,2),!,?98,$P(NODE,U,3),!
..I TYP=0,'$G(ORDST) S PQTY=+$P(NODE,U,7)+QTY,NEWBAL=PQTY W DATE,?22,PAT,?55,$J(QTY,6),?75,$J(PQTY,6),?98,$P(NODE,U,2),!,?98,$P(NODE,U,3),!
..I TYP=0,$G(ORDST)=10 D ; *62 RJS .
...S PQTY=+$P(NODE,"^")+$P(NODE,"^",7)+$P(NODE,"^",23),NEWBAL=PQTY
...W:$P(NODE,"^")'="" DATE,?22,PAT,?55,$J(QTY,6),?75,$J(PQTY,6),?98,$P(NODE,U,2),!,?98,$P(NODE,U,3),! ; < *62 RJS
... S TFDTE=$P(NODE,"^",17),Y=TFDTE X ^DD("DD") S TFDTE=$E(Y,1,17),TFNUR=$P(NODE,"^",18),T2NAOU=$P(NODE,"^",19),TTDTE=$P(NODE,"^",20)
...S TTNUR=$P(NODE,"^",21),TRQTY=+$P(NODE,"^",23),NEWBAL=+NEWBAL-TRQTY
...W TFDTE,?22,PAT,?45,"*TRFER*",?54 W:TYP=0 "-" W $J(TRQTY,6),?75,$J(NEWBAL,6)
...W ?98,$P(NODE,"^",18),!,?32,"*TRANSFER TO "_$P(NODE,"^",19),"*",?98,$P(NODE,"^",21)
;..W:$P(NODE,U,8) " recorded by ",$P($G(^VA(200,$P(NODE,U,8),0)),U)
DONE I $E(IOST)'="C" W @IOF
I $E(IOST,1,2)="C-",'PSDOUT W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="END OF REPORT! Press <RET> to return to the menu" D ^DIR K DIR
END ;
D KVAR^VADPT K VA
K %,%DT,%H,%I,%ZIS,ALL,AQTY,BAL,CNT,DA,DATE,DDATE,DFN,DIC,DIR,DIROUT,DIRUT,DQTY,DTOUT,DREAS,DRUGNO,DUOUT,LN,LOOP,NAOU,NAOUN,NEWBAL,NODE,NODE3,NODE7,NODE9,NUR1,NUR2,ORDST
K PAT,PG,POP,PSD,PSD1,PSDA,PSDATE,PSDED,PSDOUT,PSDPN,PQTY,PSDR,PSDRET,PSDRG,PSDRGN,PSDRN,PSDSD,RQTY,RREAS,RPDT,SOQTY
K T2NAOU,TFDTE,TFNUR,TPRVTR,TRQTY,TTDTE,TTNUR,TTONAOU,TQTY,TYP,QTY,SUM,UQTY,VADM,VAERR,WQTY,WREAS,X,Y
K ^TMP("PSDPAT",$J),^TMP("PSDPATL",$J),ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
SET ;sets data
;Q:TYP=11
Q:'$D(^PSD(58.81,PSDA,0)) S NODE=^(0),QTY=+$P(NODE,"^",6)
S NODE9=$G(^PSD(58.81,PSDA,9)) S SOQTY=+$P(NODE9,"^",3),WQTY=+$P(NODE9,"^",4)
I +$P(NODE,"^",5) S DRUGNO=+$P(NODE,"^",5)
I TYP=17 S $P(PSDRG(+PSDR),"^",2)=+$P(PSDRG(+PSDR),"^",2)+SOQTY
S NODE3=$G(^PSD(58.81,PSDA,3)) S PSDRET=+$P(NODE3,"^"),RQTY=+$P(NODE3,"^",2),RREAS=$P(NODE3,"^",3),DQTY=+$P(NODE3,"^",5),DREAS=$P(NODE3,"^",6),DDATE=+$P(NODE3,"^",4)
S DFN=+$P($G(NODE9),"^") D DEM^VADPT S PAT=$S(TYP=18:"WASTED AMOUNT",TYP=11:"INITIALIZE BALANCE",TYP=9:"BALANCE ADJUSTMENT",TYP=23:"COUNT VERIFICATION",'VAERR:VADM(1),1:"UNKNOWN")
S NUR1=$S($P(NODE9,U,2):$P(NODE9,U,2),1:$P(NODE,U,7))
S:NUR1'=$P(NODE,U,7) NUR1(1)=$P(NODE,U,7)
;S NUR1=$S(TYP=11:+$P(NODE,"^",7),1:+$P($G(NODE9),"^",2)) S:TYP=9 NUR1=$S(+$P(NODE,"^",7):+$P(NODE,"^",7),1:+$P($G(NODE9),"^",2))
S NUR1=$S($P($G(^VA(200,+NUR1,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
S NUR2=$P($G(NODE9),"^",6) S:NUR2 NUR2=$S($P($G(^VA(200,+NUR2,0)),"^")]"":$P(^(0),"^"),1:"")
S PSDRN=$S($P($G(^PSDRUG(+PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR_" NAME MISSING")
;I +$P(NODE9,"^",4) S QTY=+$P(NODE9,"^",4)
;I +$P(NODE9,"^",7) S QTY=+$P(NODE9,"^",7)-$P(NODE9,"^",3)
;I +$P(NODE9,"^",5) S QTY=+$P(NODE9,"^",5)
;12/9/97 added next line;added to tmp-file
SET1 ;sets ^tmp
I TYP=0 D CHKNOD7
S CNT=CNT+1,^TMP("PSDPAT",$J,PSDRN,PSD,PAT,CNT)=QTY_"^"_NUR1_"^"_NUR2_"^"_TYP_"^"_WQTY_"^"_$P(NODE,U,16)_U_$P(NODE,U,10)_"^"_$G(NUR1(1))_"^"_RQTY_"^"_RREAS_"^"_DRUGNO_"^"_SOQTY_"^"_DQTY_"^"_DREAS_"^"_PSDRET_"^"_DDATE
I $G(TRQTY) S ^TMP("PSDPAT",$J,PSDRN,PSD,PAT,CNT)=^TMP("PSDPAT",$J,PSDRN,PSD,PAT,CNT)_"^"_TFDTE_"^"_TFNUR_"^"_T2NAOU_"^"_TTDTE_"^"_TTNUR_"^"_TPRVTR_"^"_TRQTY_"^"_ORDST
S:'$D(^TMP("PSDPATL",$J,PSDRN)) ^TMP("PSDPATL",$J,PSDRN)=0
S ^TMP("PSDPATL",$J,PSDRN)=+^TMP("PSDPATL",$J,PSDRN)+($S(TYP=18:-QTY,TYP=17:-SOQTY,1:QTY)),$P(^(PSDRN),"^",2)=+PSDRG(PSDR)
S $P(^TMP("PSDPATL",$J,PSDRN),"^",3)=+$P(^TMP("PSDPATL",$J,PSDRN),"^",3)+$P(PSDRG(+PSDR),"^",2)
K QTY,NUR1,NUR2,NODE,NODE3,NODE7,PSDTR Q
SET2 ;SETS TRANSFER DATA ONLY ;; *62 RJS >
N PSDTRDT,PAT
S PSDR=$P(NODE,U,5),PSDRN=$S($P($G(^PSDRUG(+PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR_" NAME MISSING")
S PSDTRDT=$P(^PSD(58.81,PSDA,1),U,4)
Q:$D(^TMP("PSDPAT",$J,PSDRN,PSDTRDT))
S PSDTR=PSDA D CHKNOD7
I $G(TRQTY) S CNT=CNT+1,PAT="PHARMACY DISP #"_$P(NODE,U,17),^TMP("PSDPAT",$J,PSDRN,PSD,PAT,CNT)="^^^0^^^^^^^^^^^^^"_TFDTE_"^"_TFNUR_"^"_T2NAOU_"^"_TTDTE_"^"_TTNUR_"^"_TPRVTR_"^"_TRQTY_"^"_ORDST
S:'$D(^TMP("PSDPATL",$J,PSDRN)) ^TMP("PSDPATL",$J,PSDRN)=0
S $P(^TMP("PSDPATL",$J,PSDRN),"^",3)=+$P(^TMP("PSDPATL",$J,PSDRN),"^",3)+$P(PSDRG(+PSDR),"^",2)
K QTY,NUR1,NUR2,NODE,NODE3,NODE7,PSDTR
Q ; < *62 RJS
CHKNOD7 ;
S NODE7=$G(^PSD(58.81,+PSDTR,7))
S ORDST=$P($G(^PSD(58.81,+PSDTR,0)),"^",11)
S TFDTE=+$P(NODE7,"^"),TTONAOU=+$P(NODE7,U,3),T2NAOU=$P($G(^PSD(58.8,TTONAOU,0)),U),TTDTE=+$P(NODE7,U,4),TPRVTR=+$P(NODE7,U,6),TRQTY=+$P(NODE7,U,7)
S TFNUR=$S($P(NODE7,U,2):$P(NODE7,U,2),1:$P(NODE,U,7))
S:TFNUR'=$P(NODE,U,7) TFNUR(1)=$P(NODE,U,7) S TFNUR=$S($P($G(^VA(200,+TFNUR,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
S TTNUR=$P($G(NODE7),"^",5) S:TTNUR TTNUR=$S($P($G(^VA(200,+TTNUR,0)),"^")]"":$P(^(0),"^"),1:"")
Q
HDR ;header
I $E(IOST,1,2)="C-",PG K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
S PG=PG+1 W:$Y @IOF W !,?20,"Activity Report for ",NAOUN,?55,RPDT,?115,"Page: ",PG,!,?20,"Date: ",$P(PSDATE,"^")," to ",$P(PSDATE,"^",2),!!
W ?5,"=> DRUG",!,"DATE/TIME",?22,"PATIENT",?55,"QUANTITY",?75,"BALANCE",?98,"NURSE 1",!,?98,"NURSE2",!,LN,!!
Q
CHK ;sets total qty used and balance
S TQTY=+$G(^TMP("PSDPATL",$J,PSDRG)),BAL=+$P($G(^TMP("PSDPATL",$J,PSDRG)),"^",2),UQTY=BAL-TQTY
Q
TOT ;prints total qty used and balance
I $Y+4>IOSL D HDR Q:PSDOUT W !,?5,"=> ",$S(PSDRG]"":PSDRG,1:PSDRGN),!
;W !,?55,"----------",?75,"----------",!,?5,"Total Quantity Used and Balance",?55,$J(AQTY,6),?70,$J(PQTY,6),!
W ! S AQTY=0
Q
PSDPAT1 ;B'ham ISC/JPW,BJW - Prt activity report (Patient/Drug) ; 17 Apr 98
+1 ;;3.0; CONTROLLED SUBSTANCES ;**7,62**;13 Feb 97;Build 3
+2 ;modified for nois:det-0198-42285;displays drugs for destruction,returns,waste,transfers
START ;entry for compile and print
+1 KILL ^TMP("PSDPAT",$JOB)
SET (AQTY,CNT)=0
+2 IF $DATA(ALL)
FOR PSDR=0:0
SET PSDR=$ORDER(^PSD(58.8,+NAOU,1,PSDR))
IF 'PSDR
QUIT
IF $DATA(^PSD(58.8,+NAOU,1,+PSDR,0))
SET PSDRG(+PSDR)=+$PIECE(^(0),"^",4)
+3 FOR PSDR=0:0
SET PSDR=$ORDER(PSDRG(PSDR))
IF 'PSDR
QUIT
FOR PSD=PSDSD:0
SET PSD=$ORDER(^PSD(58.81,"ACT",PSD))
IF 'PSD!(PSD>PSDED)
QUIT
Begin DoDot:1
+4 FOR TYP=0:0
SET TYP=$ORDER(^PSD(58.81,"ACT",PSD,+NAOU,PSDR,TYP))
IF 'TYP
QUIT
FOR PSDA=0:0
SET PSDA=$ORDER(^PSD(58.81,"ACT",PSD,+NAOU,PSDR,TYP,PSDA))
IF 'PSDA
QUIT
DO SET
End DoDot:1
+5 ;; *62 RJS>
+6 FOR PSDR=0:0
SET PSDR=$ORDER(PSDRG(PSDR))
IF 'PSDR
QUIT
FOR PSDA=0:0
SET PSDA=$ORDER(^PSD(58.8,+NAOU,1,PSDR,3,PSDA))
IF 'PSDA
QUIT
Begin DoDot:1
+7 IF '$DATA(^PSD(58.8,NAOU,1,PSDR,3,PSDA,0))
QUIT
SET NODE=^(0)
SET PSD=$PIECE(NODE,"^",15)
+8 IF (PSD>PSDSD)
IF (PSD<PSDED)
Begin DoDot:2
+9 SET NUR1=+$PIECE(NODE,"^",7)
SET NUR2=""
SET QTY=+$PIECE(NODE,"^",20)
SET PAT="PHARMACY DISP #"_$PIECE(NODE,U,16)
SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(+PSDR,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSDR_" NAME MISSING")
SET PSDTR=+$PIECE($GET(NODE),"^",17)
+10 IF (TYP=18)!(TYP=17)
SET $PIECE(PSDRG(+PSDR),"^",2)=+$PIECE(PSDRG(+PSDR),"^",2)+QTY
+11 SET NUR1=$SELECT($PIECE($GET(^VA(200,NUR1,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
+12 SET (WQTY,WREAS,RQTY,RREAS,DRUGNO,SOQTY,DQTY,DREAS,PSDRET,DDATE)=""
+13 SET NODE9=""
SET $PIECE(NODE,U,16)=""
SET TYP=0
+14 SET $PIECE(NODE,U,10)=$PIECE(NODE,U,22)
DO SET1
End DoDot:2
End DoDot:1
+15 ;; *62 RJS>
+16 FOR PSD=PSDSD:0
SET PSD=$ORDER(^PSD(58.81,"ATRN",PSD))
IF 'PSD!(PSD>PSDED)
QUIT
Begin DoDot:1
+17 FOR PSDA=0:0
SET PSDA=$ORDER(^PSD(58.81,"ATRN",PSD,PSDA))
IF 'PSDA
QUIT
Begin DoDot:2
+18 SET NODE=^PSD(58.81,PSDA,0)
IF $PIECE(NODE,U,18)'=NAOU!('$DATA(PSDRG($PIECE(NODE,U,5))))
QUIT
DO SET2
End DoDot:2
End DoDot:1
+19 ;; <*62 RJS
+20 FOR
SET PSDR=$ORDER(PSDRG(PSDR))
IF 'PSDR
QUIT
IF $GET(PSDRG(PSDR))
SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(+PSDR,0)),U)]"":$PIECE(^(0),U),1:"ZZ/"_PSDR_" NAME MISSING")
IF '$DATA(^TMP("PSDPAT",$JOB,PSDRN))
Begin DoDot:1
+21 SET ^TMP("PSDPAT",$JOB,PSDRN,DT,"NO ACTIVITY",1)=0
+22 SET ^TMP("PSDPATL",$JOB,PSDRN)=U_PSDRG(PSDR)
End DoDot:1
PRINT ;prints data
+1 IF SUM="S"
DO ^PSDPAT2
GOTO DONE
+2 SET (PG,PSDOUT,AQTY)=0
SET PSDRN=""
SET $PIECE(LN,"-",132)=""
DO NOW^%DTC
SET Y=+$EXTRACT(%,1,12)
XECUTE ^DD("DD")
SET RPDT=Y
+3 IF '$DATA(^TMP("PSDPAT",$JOB))
DO HDR
WRITE !!,?15,"**** NO DISPENSING ACTIVITY ****",!!
GOTO DONE
+4 DO HDR
SET PSDRG=""
FOR
SET PSDRG=$ORDER(^TMP("PSDPAT",$JOB,PSDRG))
IF PSDRG=""!(PSDOUT)
QUIT
WRITE !,?5,"=> ",PSDRG,!
DO CHK
FOR PSD=0:0
SET PSD=$ORDER(^TMP("PSDPAT",$JOB,PSDRG,PSD))
IF 'PSD
DO TOT
IF PSD=""!(PSDOUT)
QUIT
Begin DoDot:1
+5 SET PAT=""
FOR
SET PAT=$ORDER(^TMP("PSDPAT",$JOB,PSDRG,PSD,PAT))
IF PAT=""!(PSDOUT)
QUIT
FOR PSD1=0:0
SET PSD1=$ORDER(^TMP("PSDPAT",$JOB,PSDRG,PSD,PAT,PSD1))
IF 'PSD1!(PSDOUT)
QUIT
Begin DoDot:2
+6 SET (QTY,SOQTY,RQTY,WQTY,DQTY,NEWBAL,ORDST)=0
SET (RREAS,WREAS,DREAS)=""
+7 SET NODE=^TMP("PSDPAT",$JOB,PSDRG,PSD,PAT,PSD1)
SET PSDRGN=PSDRG
+8 IF $PIECE(NODE,U,4)=3
QUIT
+9 WRITE !
+10 IF $Y+8>IOSL
DO HDR
IF PSDOUT
QUIT
WRITE !,?5,"=> ",PSDRG,!
+11 SET Y=+$EXTRACT(PSD,1,12)
XECUTE ^DD("DD")
SET DATE=Y
+12 SET TYP=+$PIECE(NODE,"^",4)
SET PSDR=$PIECE(NODE,"^",11)
SET ORDST=+$PIECE(NODE,"^",24)
+13 SET QTY=+$PIECE(NODE,"^")
+14 IF (TYP)=9
SET PQTY=+$PIECE(NODE,U,7)+QTY
SET NEWBAL=PQTY
WRITE DATE,?22,PAT,?55,$JUSTIFY(QTY,6),?75,$JUSTIFY(PQTY,6),?98,$PIECE(NODE,U,2),!,?98,$PIECE(NODE,U,3),!,?25,$PIECE(NODE,U,6),!
+15 IF TYP=11
SET PQTY=+$PIECE(NODE,U,7)+QTY
SET NEWBAL=PQTY
WRITE DATE,?22,PAT,?55,$JUSTIFY(QTY,6),?75,$JUSTIFY(PQTY,6),?98,$PIECE(NODE,U,2),!,?98,$PIECE(NODE,U,3),!
+16 IF TYP=17
SET SOQTY=+$PIECE(NODE,"^",12)
SET NEWBAL=+$PIECE(NODE,"^",7)-SOQTY
Begin DoDot:3
+17 WRITE DATE,?22,PAT,?54
IF TYP=17
WRITE "-"
WRITE $JUSTIFY(SOQTY,6)
+18 WRITE ?75,$JUSTIFY(NEWBAL,6),?98,$PIECE(NODE,"^",2),!,?98,$PIECE(NODE,"^",3),!
End DoDot:3
+19 IF (TYP=17)
IF (+$PIECE(NODE,"^",9))
SET RQTY=+$PIECE(NODE,"^",9)
Begin DoDot:3
+20 SET RREAS=$PIECE(NODE,"^",10)
SET NEWBAL=+NEWBAL+RQTY
SET PSDRET=$PIECE(NODE,"^",15)
SET Y=PSDRET
XECUTE ^DD("DD")
SET PSDRET=$EXTRACT(Y,1,17)
+21 IF $GET(PSDRET)=0
SET PSDRET=""
WRITE PSDRET,?22,PAT,?45,"*RETURN*",?55,$JUSTIFY(RQTY,6),?75,$JUSTIFY(NEWBAL,6),?98,$PIECE(NODE,"^",2),!,?25,RREAS,?98,$PIECE(NODE,"^",3),!
End DoDot:3
+22 IF +$PIECE(NODE,U,5)
SET WQTY=+$PIECE(NODE,U,5)
SET WREAS=$PIECE(NODE,"^",6)
SET QTY=QTY-WQTY
Begin DoDot:3
+23 WRITE DATE,?22,PAT,?45,"*WASTED*",?55,$JUSTIFY(WQTY,6)
+24 WRITE ?98,$PIECE(NODE,"^",2),!,?25,WREAS,?98,$PIECE(NODE,"^",3),!
End DoDot:3
+25 IF +$PIECE(NODE,U,13)
SET DQTY=+$PIECE(NODE,U,13)
SET DREAS=$PIECE(NODE,U,14)
SET DDATE=+$PIECE(NODE,U,16)
Begin DoDot:3
+26 WRITE DATE,?22,PAT,?45,"*DESTROY*",?55,$JUSTIFY(DQTY,6),?98,$PIECE(NODE,"^",2),!,?25,DREAS,?98,$PIECE(NODE,"^",3),!
End DoDot:3
+27 IF TYP=17
WRITE DATE,?22,PAT,?45,"*GIVEN*",?55,$JUSTIFY(QTY,6),!
+28 IF TYP=23
SET PQTY=+$PIECE(NODE,U,7)+QTY
SET NEWBAL=PQTY
WRITE DATE,?22,PAT,?55,$JUSTIFY(QTY,6),?75,$JUSTIFY(PQTY,6),?98,$PIECE(NODE,U,2),!,?98,$PIECE(NODE,U,3),!
+29 IF TYP=0
IF '$GET(ORDST)
SET PQTY=+$PIECE(NODE,U,7)+QTY
SET NEWBAL=PQTY
WRITE DATE,?22,PAT,?55,$JUSTIFY(QTY,6),?75,$JUSTIFY(PQTY,6),?98,$PIECE(NODE,U,2),!,?98,$PIECE(NODE,U,3),!
+30 ; *62 RJS .
IF TYP=0
IF $GET(ORDST)=10
Begin DoDot:3
+31 SET PQTY=+$PIECE(NODE,"^")+$PIECE(NODE,"^",7)+$PIECE(NODE,"^",23)
SET NEWBAL=PQTY
+32 ; < *62 RJS
IF $PIECE(NODE,"^")'=""
WRITE DATE,?22,PAT,?55,$JUSTIFY(QTY,6),?75,$JUSTIFY(PQTY,6),?98,$PIECE(NODE,U,2),!,?98,$PIECE(NODE,U,3),!
+33 SET TFDTE=$PIECE(NODE,"^",17)
SET Y=TFDTE
XECUTE ^DD("DD")
SET TFDTE=$EXTRACT(Y,1,17)
SET TFNUR=$PIECE(NODE,"^",18)
SET T2NAOU=$PIECE(NODE,"^",19)
SET TTDTE=$PIECE(NODE,"^",20)
+34 SET TTNUR=$PIECE(NODE,"^",21)
SET TRQTY=+$PIECE(NODE,"^",23)
SET NEWBAL=+NEWBAL-TRQTY
+35 WRITE TFDTE,?22,PAT,?45,"*TRFER*",?54
IF TYP=0
WRITE "-"
WRITE $JUSTIFY(TRQTY,6),?75,$JUSTIFY(NEWBAL,6)
+36 WRITE ?98,$PIECE(NODE,"^",18),!,?32,"*TRANSFER TO "_$PIECE(NODE,"^",19),"*",?98,$PIECE(NODE,"^",21)
End DoDot:3
End DoDot:2
IF PSDOUT
QUIT
End DoDot:1
IF PSDOUT
QUIT
+37 ;..W:$P(NODE,U,8) " recorded by ",$P($G(^VA(200,$P(NODE,U,8),0)),U)
DONE IF $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST,1,2)="C-"
IF 'PSDOUT
WRITE !
KILL DIR,DIRUT
SET DIR(0)="EA"
SET DIR("A")="END OF REPORT! Press <RET> to return to the menu"
DO ^DIR
KILL DIR
END ;
+1 DO KVAR^VADPT
KILL VA
+2 KILL %,%DT,%H,%I,%ZIS,ALL,AQTY,BAL,CNT,DA,DATE,DDATE,DFN,DIC,DIR,DIROUT,DIRUT,DQTY,DTOUT,DREAS,DRUGNO,DUOUT,LN,LOOP,NAOU,NAOUN,NEWBAL,NODE,NODE3,NODE7,NODE9,NUR1,NUR2,ORDST
+3 KILL PAT,PG,POP,PSD,PSD1,PSDA,PSDATE,PSDED,PSDOUT,PSDPN,PQTY,PSDR,PSDRET,PSDRG,PSDRGN,PSDRN,PSDSD,RQTY,RREAS,RPDT,SOQTY
+4 KILL T2NAOU,TFDTE,TFNUR,TPRVTR,TRQTY,TTDTE,TTNUR,TTONAOU,TQTY,TYP,QTY,SUM,UQTY,VADM,VAERR,WQTY,WREAS,X,Y
+5 KILL ^TMP("PSDPAT",$JOB),^TMP("PSDPATL",$JOB),ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+6 DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+7 QUIT
SET ;sets data
+1 ;Q:TYP=11
+2 IF '$DATA(^PSD(58.81,PSDA,0))
QUIT
SET NODE=^(0)
SET QTY=+$PIECE(NODE,"^",6)
+3 SET NODE9=$GET(^PSD(58.81,PSDA,9))
SET SOQTY=+$PIECE(NODE9,"^",3)
SET WQTY=+$PIECE(NODE9,"^",4)
+4 IF +$PIECE(NODE,"^",5)
SET DRUGNO=+$PIECE(NODE,"^",5)
+5 IF TYP=17
SET $PIECE(PSDRG(+PSDR),"^",2)=+$PIECE(PSDRG(+PSDR),"^",2)+SOQTY
+6 SET NODE3=$GET(^PSD(58.81,PSDA,3))
SET PSDRET=+$PIECE(NODE3,"^")
SET RQTY=+$PIECE(NODE3,"^",2)
SET RREAS=$PIECE(NODE3,"^",3)
SET DQTY=+$PIECE(NODE3,"^",5)
SET DREAS=$PIECE(NODE3,"^",6)
SET DDATE=+$PIECE(NODE3,"^",4)
+7 SET DFN=+$PIECE($GET(NODE9),"^")
DO DEM^VADPT
SET PAT=$SELECT(TYP=18:"WASTED AMOUNT",TYP=11:"INITIALIZE BALANCE",TYP=9:"BALANCE ADJUSTMENT",TYP=23:"COUNT VERIFICATION",'VAERR:VADM(1),1:"UNKNOWN")
+8 SET NUR1=$SELECT($PIECE(NODE9,U,2):$PIECE(NODE9,U,2),1:$PIECE(NODE,U,7))
+9 IF NUR1'=$PIECE(NODE,U,7)
SET NUR1(1)=$PIECE(NODE,U,7)
+10 ;S NUR1=$S(TYP=11:+$P(NODE,"^",7),1:+$P($G(NODE9),"^",2)) S:TYP=9 NUR1=$S(+$P(NODE,"^",7):+$P(NODE,"^",7),1:+$P($G(NODE9),"^",2))
+11 SET NUR1=$SELECT($PIECE($GET(^VA(200,+NUR1,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
+12 SET NUR2=$PIECE($GET(NODE9),"^",6)
IF NUR2
SET NUR2=$SELECT($PIECE($GET(^VA(200,+NUR2,0)),"^")]"":$PIECE(^(0),"^"),1:"")
+13 SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(+PSDR,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSDR_" NAME MISSING")
+14 ;I +$P(NODE9,"^",4) S QTY=+$P(NODE9,"^",4)
+15 ;I +$P(NODE9,"^",7) S QTY=+$P(NODE9,"^",7)-$P(NODE9,"^",3)
+16 ;I +$P(NODE9,"^",5) S QTY=+$P(NODE9,"^",5)
+17 ;12/9/97 added next line;added to tmp-file
SET1 ;sets ^tmp
+1 IF TYP=0
DO CHKNOD7
+2 SET CNT=CNT+1
SET ^TMP("PSDPAT",$JOB,PSDRN,PSD,PAT,CNT)=QTY_"^"_NUR1_"^"_NUR2_"^"_TYP_"^"_WQTY_"^"_$PIECE(NODE,U,16)_U_$PIECE(NODE,U,10)_"^"_$GET(NUR1(1))_"^"_RQTY_"^"_RREAS_"^"_DRUGNO_"^"_SOQTY_"^"_DQTY_"^"_DREAS_"^"_PSDRET_"^"_DDATE
+3 IF $GET(TRQTY)
SET ^TMP("PSDPAT",$JOB,PSDRN,PSD,PAT,CNT)=^TMP("PSDPAT",$JOB,PSDRN,PSD,PAT,CNT)_"^"_TFDTE_"^"_TFNUR_"^"_T2NAOU_"^"_TTDTE_"^"_TTNUR_"^"_TPRVTR_"^"_TRQTY_"^"_ORDST
+4 IF '$DATA(^TMP("PSDPATL",$JOB,PSDRN))
SET ^TMP("PSDPATL",$JOB,PSDRN)=0
+5 SET ^TMP("PSDPATL",$JOB,PSDRN)=+^TMP("PSDPATL",$JOB,PSDRN)+($SELECT(TYP=18:-QTY,TYP=17:-SOQTY,1:QTY))
SET $PIECE(^(PSDRN),"^",2)=+PSDRG(PSDR)
+6 SET $PIECE(^TMP("PSDPATL",$JOB,PSDRN),"^",3)=+$PIECE(^TMP("PSDPATL",$JOB,PSDRN),"^",3)+$PIECE(PSDRG(+PSDR),"^",2)
+7 KILL QTY,NUR1,NUR2,NODE,NODE3,NODE7,PSDTR
QUIT
SET2 ;SETS TRANSFER DATA ONLY ;; *62 RJS >
+1 NEW PSDTRDT,PAT
+2 SET PSDR=$PIECE(NODE,U,5)
SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(+PSDR,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSDR_" NAME MISSING")
+3 SET PSDTRDT=$PIECE(^PSD(58.81,PSDA,1),U,4)
+4 IF $DATA(^TMP("PSDPAT",$JOB,PSDRN,PSDTRDT))
QUIT
+5 SET PSDTR=PSDA
DO CHKNOD7
+6 IF $GET(TRQTY)
SET CNT=CNT+1
SET PAT="PHARMACY DISP #"_$PIECE(NODE,U,17)
SET ^TMP("PSDPAT",$JOB,PSDRN,PSD,PAT,CNT)="^^^0^^^^^^^^^^^^^"_TFDTE_"^"_TFNUR_"^"_T2NAOU_"^"_TTDTE_"^"_TTNUR_"^"_TPRVTR_"^"_TRQTY_"^"_ORDST
+7 IF '$DATA(^TMP("PSDPATL",$JOB,PSDRN))
SET ^TMP("PSDPATL",$JOB,PSDRN)=0
+8 SET $PIECE(^TMP("PSDPATL",$JOB,PSDRN),"^",3)=+$PIECE(^TMP("PSDPATL",$JOB,PSDRN),"^",3)+$PIECE(PSDRG(+PSDR),"^",2)
+9 KILL QTY,NUR1,NUR2,NODE,NODE3,NODE7,PSDTR
+10 ; < *62 RJS
QUIT
CHKNOD7 ;
+1 SET NODE7=$GET(^PSD(58.81,+PSDTR,7))
+2 SET ORDST=$PIECE($GET(^PSD(58.81,+PSDTR,0)),"^",11)
+3 SET TFDTE=+$PIECE(NODE7,"^")
SET TTONAOU=+$PIECE(NODE7,U,3)
SET T2NAOU=$PIECE($GET(^PSD(58.8,TTONAOU,0)),U)
SET TTDTE=+$PIECE(NODE7,U,4)
SET TPRVTR=+$PIECE(NODE7,U,6)
SET TRQTY=+$PIECE(NODE7,U,7)
+4 SET TFNUR=$SELECT($PIECE(NODE7,U,2):$PIECE(NODE7,U,2),1:$PIECE(NODE,U,7))
+5 IF TFNUR'=$PIECE(NODE,U,7)
SET TFNUR(1)=$PIECE(NODE,U,7)
SET TFNUR=$SELECT($PIECE($GET(^VA(200,+TFNUR,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
+6 SET TTNUR=$PIECE($GET(NODE7),"^",5)
IF TTNUR
SET TTNUR=$SELECT($PIECE($GET(^VA(200,+TTNUR,0)),"^")]"":$PIECE(^(0),"^"),1:"")
+7 QUIT
HDR ;header
+1 IF $EXTRACT(IOST,1,2)="C-"
IF PG
KILL DA,DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSDOUT=1
QUIT
+2 SET PG=PG+1
IF $Y
WRITE @IOF
WRITE !,?20,"Activity Report for ",NAOUN,?55,RPDT,?115,"Page: ",PG,!,?20,"Date: ",$PIECE(PSDATE,"^")," to ",$PIECE(PSDATE,"^",2),!!
+3 WRITE ?5,"=> DRUG",!,"DATE/TIME",?22,"PATIENT",?55,"QUANTITY",?75,"BALANCE",?98,"NURSE 1",!,?98,"NURSE2",!,LN,!!
+4 QUIT
CHK ;sets total qty used and balance
+1 SET TQTY=+$GET(^TMP("PSDPATL",$JOB,PSDRG))
SET BAL=+$PIECE($GET(^TMP("PSDPATL",$JOB,PSDRG)),"^",2)
SET UQTY=BAL-TQTY
+2 QUIT
TOT ;prints total qty used and balance
+1 IF $Y+4>IOSL
DO HDR
IF PSDOUT
QUIT
WRITE !,?5,"=> ",$SELECT(PSDRG]"":PSDRG,1:PSDRGN),!
+2 ;W !,?55,"----------",?75,"----------",!,?5,"Total Quantity Used and Balance",?55,$J(AQTY,6),?70,$J(PQTY,6),!
+3 WRITE !
SET AQTY=0
+4 QUIT
