PSDPAT1 ;B'ham ISC/JPW,BJW - Prt activity report (Patient/Drug) ; 17 Apr 98
;;3.0;CONTROLLED SUBSTANCES ;**7,62,68,72**;13 Feb 97;Build 8
;modified for nois:det-0198-42285;displays drugs for destruction,returns,waste,transfers
START ;entry for compile and print
K ^TMP("PSDPAT",$J),^TMP("PSDPAT1",$J),^TMP("PSDPATL",$J) S (PSDAQTY,PSDCNT)=0,PSDNAOU=NAOU
I $D(ALL) F PSDR=0:0 S PSDR=$O(^PSD(58.8,+PSDNAOU,1,PSDR)) Q:'PSDR I $D(^PSD(58.8,+PSDNAOU,1,+PSDR,0)) S PSDRG(+PSDR)=+$P(^(0),U,4)
F PSDR=0:0 S PSDR=$O(PSDRG(PSDR)) Q:'PSDR D
.F PSD=PSDSD:0 S PSD=$O(^PSD(58.81,"ACT",PSD)) Q:'PSD D
..S PSD58=0 F S PSD58=$O(^PSD(58.81,"ACT",PSD,PSD58)) Q:'PSD58 D
...F PSDTYP=0:0 S PSDTYP=$O(^PSD(58.81,"ACT",PSD,PSD58,PSDR,PSDTYP)) Q:'PSDTYP D
....F PSDA=0:0 S PSDA=$O(^PSD(58.81,"ACT",PSD,PSD58,PSDR,PSDTYP,PSDA)) Q:'PSDA I $P(^PSD(58.81,PSDA,0),U,18)=PSDNAOU!($P(^PSD(58.81,PSDA,0),U,3)=PSDNAOU) D
.....D CHK2
.....Q:$D(^TMP("PSDPAT1",$J,PSDR,PSDA))
.....I $D(^PSD(58.81,PSDA,1)),$P(^PSD(58.81,PSDA,1),"^",4)<PSDSD S PSDSTOP=1
.....I $D(^PSD(58.81,PSDA,3)) S PSDSTOP=0
.....Q:$G(PSDSTOP)
.....S PSDEND=0 I PSD>PSDED S PSDEND=1
.....S ^TMP("PSDPAT1",$J,PSDR,PSDA)=PSDEND
F PSDR=0:0 S PSDR=$O(PSDRG(PSDR)) Q:'PSDR D
.F PSD=PSDSD:0 S PSD=$O(^PSD(58.81,"AK",PSD)) Q:'PSD D
..S PSDA=0 F S PSDA=$O(^PSD(58.81,"AK",PSD,PSDNAOU,PSDA)) Q:'PSDA D
...Q:$P(^PSD(58.81,PSDA,0),"^",5)'=PSDR
...D CHK2
...Q:$D(^TMP("PSDPAT1",$J,PSDR,PSDA))
...I $D(^PSD(58.81,PSDA,1)),$P(^PSD(58.81,PSDA,1),"^",4)<PSDSD S PSDSTOP=1
...Q:$G(PSDSTOP)
...S PSDEND=0 I PSD>PSDED S PSDEND=1
...S ^TMP("PSDPAT1",$J,PSDR,PSDA)=PSDEND
F PSDR=0:0 S PSDR=$O(PSDRG(PSDR)) Q:'PSDR F PSDA=0:0 S PSDA=$O(^PSD(58.8,+PSDNAOU,1,PSDR,3,PSDA)) Q:'PSDA D
.Q:'$D(^PSD(58.8,PSDNAOU,1,PSDR,3,PSDA,0)) S PSD0=^(0),PSD=$P(PSD0,U,15)
.I (PSD>PSDSD) D
..S PSDEND=0 I PSD>PSDED S PSDEND=1
..S PSDTR=+$P($G(PSD0),U,17),PSDTYP=$P(^PSD(58.81,PSDTR,0),U,2),PSDSTOP=0 I PSDTYP'=23 D CHK2
..Q:$G(PSDSTOP)!($D(^TMP("PSDPAT1",$J,PSDR,PSDTR)))
..S ^TMP("PSDPAT1",$J,PSDR,PSDTR)=PSDEND
F PSD=PSDSD:0 S PSD=$O(^PSD(58.81,"ATRN",PSD)) Q:'PSD D
.F PSDA=0:0 S PSDA=$O(^PSD(58.81,"ATRN",PSD,PSDA)) Q:'PSDA D
..S PSD0=^PSD(58.81,PSDA,0) Q:$P(PSD0,U,18)'=NAOU!('$D(PSDRG($P(PSD0,U,5)))) D
...S PSDEND=0 I PSD>PSDED S PSDEND=1
...Q:$D(^TMP("PSDPAT1",$J,$P(PSD0,U,5),PSDA))
...S:PSDRG($P(PSD0,U,5)) ^TMP("PSDPAT1",$J,$P(PSD0,U,5),PSDA)=PSDEND
S PSDRUG=0 F S PSDRUG=$O(^TMP("PSDPAT1",$J,PSDRUG)) Q:'PSDRUG D
.S (PSDNBAL,PSDA)=0 F S PSDA=$O(^TMP("PSDPAT1",$J,PSDRUG,PSDA)) Q:'PSDA D
..S PSD0=$G(^PSD(58.81,PSDA,0)),PSDTYP=$P(PSD0,U,2),PSD=$P(PSD0,U,4),PSDRQ=""
..S PSDRN=$S($P($G(^PSDRUG(+PSDRUG,0)),U)]"":$P(^(0),U),1:"ZZ/"_PSDRUG_" NAME MISSING")
..Q:$P(PSD0,U,11)=3!($P(PSD0,U,2)=12)
..S PSDSTOP=0 I PSDTYP'=23 D CHK2
..Q:$G(PSDSTOP)
..S PSDEND=$G(^TMP("PSDPAT1",$J,PSDRUG,PSDA))
..I PSDTYP'=17 S PSDRQ=$P(^PSD(58.81,PSDA,0),U,20) S:$G(PSDRQ) PSD0=$G(^PSD(58.8,PSDNAOU,1,PSDRUG,3,PSDRQ,0))
..I '$G(PSDRQ) D Q
...S PSDBAL=$P(PSD0,U,10)
...D SET^PSDPAT2 Q
..I $G(PSDRQ) D Q
...S PSD=$P(PSD0,U,15)
...Q:'$G(PSD)
...S PSDNR1=+$P(PSD0,U,7),PSDNR2="",PSDQTY=+$P(PSD0,U,20),PSDBAL=$P(PSD0,U,22),PSDPAT="PHARMACY DISP #"_$P(PSD0,U,16)
...S PSDRN=$S($P($G(^PSDRUG(+PSDRUG,0)),U)]"":$P(^(0),U),1:"ZZ/"_PSDRUG_" NAME MISSING") S PSDTR=+$P($G(PSD0),U,17)
...I (PSDTYP=18)!(PSDTYP=17) S $P(PSDRG(+PSDRUG),U,2)=+$P(PSDRG(+PSDRUG),U,2)+PSDQTY
...S PSDNR1=$S($P($G(^VA(200,PSDNR1,0)),U)]"":$P(^(0),U),1:"UNKNOWN")
...S (PSDWQT,PSDWRE,PSDRQT,PSDRRE,PSDDRG1,PSDSOQT,PSDDQT,PSDDRE,PSDRET,PSDDT)="",PSD9="",$P(PSD0,U,16)="",PSDTYP=0
...S PSD3=$G(^PSD(58.81,PSDA,3))
...I $P(^PSD(58.81,PSDA,0),U,2)=9 S PSDTYP=9 D SET^PSDPAT2 Q
...I $P(^PSD(58.81,PSDA,0),U,2)=5 S PSDTYP=5 D SET2^PSDPAT2 Q
...S $P(PSD0,U,10)=$P(PSD0,U,22) D SET1^PSDPAT2
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,^TMP("PSDPATL",$J,PSDRN)=U_PSDRG(PSDR)
PRINT ;prints data
I SUM="S" D ^PSDPAT2 G DONE
S (PG,PSDOUT,PSDAQTY)=0,PSDRN="",$P(LN,"-",132)="" D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S PSDRPDT=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 PSDPAT="" F S PSDPAT=$O(^TMP("PSDPAT",$J,PSDRG,PSD,PSDPAT)) Q:PSDPAT=""!(PSDOUT) F PSD1=0:0 S PSD1=$O(^TMP("PSDPAT",$J,PSDRG,PSD,PSDPAT,PSD1)) Q:'PSD1!(PSDOUT) D Q:PSDOUT
..S (PSDQTY,PSDSOQT,PSDRQT,PSDWQT,PSDDQT,PSDSTAT)=0,(PSDRRE,PSDWRE,PSDDRE)=""
..S PSD0=^TMP("PSDPAT",$J,PSDRG,PSD,PSDPAT,PSD1),PSDRGN=PSDRG
..Q:$P(PSD0,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 PSDT=Y
..I $G(PSD0)=0 S PSDQTY=0,PSDPQT=$P(^TMP("PSDPATL",$J,PSDRGN),U,2) W PSDT,?22,PSDPAT,?55,$J(PSDQTY,6),?75,$J(PSDPQT,6),! Q
..S PSDTYP=+$P(PSD0,U,4),PSDR=$P(PSD0,U,11),PSDSTAT=+$P(PSD0,U,24),PSDQTY=+$P(PSD0,U)
..I (PSDTYP)=9,+$P(PSD0,U,5) D
...S PSDPQT=+PSDNBAL+PSDQTY,PSDNBAL=PSDPQT W PSDT,?22,PSDPAT,?45,"*WASTED*",?55,$J(PSDQTY,6),?75,$J(PSDPQT,6),?98,$P(PSD0,U,2),!
...S PSDWQT=+$P(PSD0,U,5),PSDWRE=$P(PSD0,U,6),PSDQTY=PSDQTY-PSDWQT
...W ?25,PSDWRE,?55,$J(PSDWQT,6),?98,$P(PSD0,U,3),!
..I (PSDTYP)=9,'+$P(PSD0,U,5) S PSDPQT=+PSDNBAL+PSDQTY,PSDNBAL=PSDPQT W PSDT,?22,PSDPAT,?55,$J(PSDQTY,6),?75,$J(PSDPQT,6),?98,$P(PSD0,U,2),!,?98,$P(PSD0,U,3),!,?25,$P(PSD0,U,6),!
..I PSDTYP=11 S PSDPQT=+PSDNBAL+PSDQTY,PSDNBAL=PSDPQT W PSDT,?22,PSDPAT,?55,$J(PSDQTY,6),?75,$J(PSDPQT,6),?98,$P(PSD0,U,2),!,?98,$P(PSD0,U,3),!
..I (+$P(PSD0,U,9)) S PSDRQT=+$P(PSD0,U,9)
..I PSDTYP=17 D
...S PSDSOQT=+$P(PSD0,U,12)+$P(PSD0,U,5),PSDNBAL=+(PSDNBAL-PSDSOQT)+PSDRQT D
....W PSDT,?22,PSDPAT,?54 W:PSDTYP=17 "-" W $J(PSDSOQT,6)
....W ?75,$J(PSDNBAL,6),?98,$P(PSD0,U,2),! W:$P(PSD0,U,3)'="" ?98,$P(PSD0,U,3),!
....W PSDT,?22,PSDPAT,?45,"*GIVEN*" S PSDQTY=$P(PSD0,U,12) W ?55,$J(PSDQTY,6),!
....I PSDRQT S PSDPRT=1 D PRTRET
..I (PSDTYP)'=9,+$P(PSD0,U,5) S PSDWQT=+$P(PSD0,U,5),PSDWRE=$P(PSD0,U,6),PSDQTY=PSDQTY-PSDWQT D
...W PSDT,?22,PSDPAT,?45,"*WASTED*",?55,$J(PSDWQT,6)
...W ?98,$P(PSD0,U,2),!,?25,PSDWRE,?98,$P(PSD0,U,3),!
..I PSDTYP=23 S PSDPQT=+PSDNBAL+PSDQTY,PSDNBAL=PSDPQT W PSDT,?22,PSDPAT,?55,$J(PSDQTY,6),?75,$J(PSDPQT,6),?98,$P(PSD0,U,2),!,?98,$P(PSD0,U,3),!
..I PSDTYP=0,'$G(PSDSTAT) D
...S PSDPQT=+PSDNBAL+PSDQTY,PSDNBAL=PSDPQT W PSDT,?22,PSDPAT,?55,$J(PSDQTY,6),?75,$J(PSDPQT,6),?98,$P(PSD0,U,2),! I $P(PSD0,U,3)'="" W ?98,$P(PSD0,U,3),!
...S PSDRQT=+$P(PSD0,U,9),PSDPRT=0 I $G(PSDRQT) D PRTRET
..I PSDTYP=0,$G(PSDSTAT)=10 D
...S PSDPQT=+PSDNBAL+$P(PSD0,U),PSDNBAL=PSDPQT
...W:$P(PSD0,U)'=0 PSDT,?22,PSDPAT,?55,$J(PSDQTY,6),?75,$J(PSDPQT,6),?98,$P(PSD0,U,2),!,?98,$P(PSD0,U,3),! ; < *62 RJS
... S PSDTFDT=$P(PSD0,U,17),Y=PSDTFDT X ^DD("DD") S PSDTFDT=$E(Y,1,17),PSDTFN=$P(PSD0,U,18),PSDT2N=$P(PSD0,U,19),PSDTTDT=$P(PSD0,U,20)
...S PSDTTNR=$P(PSD0,U,21),PSDTRQT=+$P(PSD0,U,23),PSDNBAL=+PSDNBAL-PSDTRQT D PRTTRT
..I PSDTYP=5,'$G(PSDSTAT) S PSDPQT=+PSDNBAL+PSDQTY,PSDNBAL=PSDPQT D
...W PSDT,?22,PSDPAT,?45,"*TRFER*",?55,$J(PSDQTY,6),?75,$J(PSDPQT,6),?98,$P(PSD0,U,2),! I $P(PSD0,U,3)'="" W ?98,$P(PSD0,U,3),!
...W ?29,"*TRANSFERED FROM "_$P(PSD0,U,19),"*",?98,$P(PSD0,U,21)
...S PSDRQT=+$P(PSD0,U,9) I $G(PSDRQT) D
....S PSDRRE=$P(PSD0,U,10),PSDNBAL=+PSDNBAL-PSDRQT,PSDRET=$P(PSD0,U,15),Y=PSDRET X ^DD("DD") S PSDRET=$E(Y,1,17)
....S:$G(PSDRET)=0 PSDRET="" W !,PSDRET,?22,PSDPAT,?45,"*RETURN* -",?55,$J(PSDRQT,6),?75,$J(PSDNBAL,6),?98,$P(PSD0,U,2),!,?25,PSDRRE,?98,!
..I +$P(PSD0,U,13) S PSDDQT=+$P(PSD0,U,13),PSDDRE=$P(PSD0,U,14),PSDDT=+$P(PSD0,U,16),PSDNBAL=PSDNBAL-PSDDQT D
...W PSDT,?22,PSDPAT,?44,"*DESTROY* -",?55,$J(PSDDQT,6),?75,$J(PSDNBAL,6),?98,$P(PSD0,U,2),!,?25,PSDDRE,?98,$P(PSD0,U,3),!
..I PSDTYP=5,$G(PSDSTAT)=10 D
...S PSDPQT=+PSDNBAL+$P(PSD0,U)-$P(PSD0,U,23),PSDNBAL=PSDPQT
...W:$P(PSD0,U)'="" PSDT,?22,PSDPAT,?55,$J(PSDQTY,6),?75,$J(PSDPQT,6),?98,$P(PSD0,U,2),!,?98,$P(PSD0,U,3),! ; < *62 RJS
... S PSDTFDT=$P(PSD0,U,17),Y=PSDTFDT X ^DD("DD") S PSDTFDT=$E(Y,1,17),PSDTFN=$P(PSD0,U,18),PSDT2N=$P(PSD0,U,19),PSDTTDT=$P(PSD0,U,20)
...S PSDTTNR=$P(PSD0,U,21),PSDTRQT=+$P(PSD0,U,23) D PRTTRT
..I PSDTYP=99,+$P(PSD0,U,9)'=0 D
...S PSDRQT=+$P(PSD0,U,9),PSDNBAL=+PSDNBAL-PSDRQT D PRTRET
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,%,%DT,%H,%I,%ZIS,ALL,PSDAQTY,PSDBAL,PSDCNT,DA,PSDT,PSDDT,DFN,DIC,DIR,DIROUT,DIRUT,PSDDQT,DTOUT,PSDDRE,PSDDRG1,DUOUT,LN,LOOP,PSDNAOU,NAOU,NAOUN,PSDNBAL,PSD0,PSD3,PSD7,PSD9,PSDNR1,PSDSTOP
K PSDNR2,PSDSTAT,PSDPAT,PG,POP,PSD,PSD1,PSDA,PSDATE,PSDED,PSDOUT,PSDPN,PSDPQT,PSDR,PSDRET,PSDRG,PSDRGN,PSDRN,PSDSD,PSDRQT,PSDRRE,PSDRPDT,PSDSOQT,PSD58,PSDRQ,PSDRUG,PSDTBAL,PSDTMP,PSDEND,PSDT2N,PSDTFDT,PSDPRT
K PSDTFN,PSDTPRV,PSDTR,PSDTRQT,PSDTTDT,PSDTTNR,PSDTTON,PSDTQTY,PSDTYP,PSDQTY,SUM,PSDUQT,VADM,VAERR,PSDWQT,PSDWRE,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK,^TMP("PSDPAT",$J),^TMP("PSDPAT1",$J),^TMP("PSDPATB",$J),^TMP("PSDPATL",$J)
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
PRTTRT ; PRINT TRANSFER TO INFORMATION
W PSDTFDT,?22,PSDPAT,?45,"*TRFER* -",?55,$J(PSDTRQT,6),?75,$J(PSDNBAL,6),?98,$P(PSD0,U,18),!,?32,"*TRANSFER TO "_$P(PSD0,U,19),"*",?98,$P(PSD0,U,21),!
Q
PRTRET ; PRINT RETURN INFORMATION
S PSDRRE=$P(PSD0,U,10),PSDRET=$P(PSD0,U,15),Y=PSDRET X ^DD("DD") S PSDRET=$E(Y,1,17)
S:$G(PSDRET)=0 PSDRET="",PSDNBAL=+PSDNBAL-PSDRQT
W PSDRET,?22,PSDPAT,?45,"*RETURN*" W:'$G(PSDPRT) " -" W ?55,$J(PSDRQT,6) W:'$G(PSDPRT) ?75,$J(PSDNBAL,6)
W ?98,$P(PSD0,U,2),!,?25,PSDRRE,?98,$P(PSD0,U,3),!
K PSDPRT
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,PSDRPDT,?115,"Page: ",PG,!,?20,"Date: ",$P(PSDATE,U)," to ",$P(PSDATE,U,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 PSDTQTY=+$G(^TMP("PSDPATL",$J,PSDRG)),PSDBAL=+$P($G(^TMP("PSDPATL",$J,PSDRG)),U,2),PSDUQT=PSDBAL-PSDTQTY,PSDNBAL=$P($G(^TMP("PSDPATL",$J,PSDRG)),U,2)-$P($G(^TMP("PSDPATL",$J,PSDRG)),U,1)
Q
CHK2 ;CHECK THE TTYPE
S PSDSTOP=0 I PSDTYP'=23 D
.I '$D(^PSD(58.81,PSDA,1)) D
..I PSDTYP'=17 S PSDSTOP=1
..I PSDTYP=9 S PSDSTOP=0
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(PSDAQTY,6),?70,$J(PSDPQT,6),!
W ! S PSDAQTY=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDPAT1 10969 printed Oct 16, 2024@17:48:44 Page 2
PSDPAT1 ;B'ham ISC/JPW,BJW - Prt activity report (Patient/Drug) ; 17 Apr 98
+1 ;;3.0;CONTROLLED SUBSTANCES ;**7,62,68,72**;13 Feb 97;Build 8
+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),^TMP("PSDPAT1",$JOB),^TMP("PSDPATL",$JOB)
SET (PSDAQTY,PSDCNT)=0
SET PSDNAOU=NAOU
+2 IF $DATA(ALL)
FOR PSDR=0:0
SET PSDR=$ORDER(^PSD(58.8,+PSDNAOU,1,PSDR))
if 'PSDR
QUIT
IF $DATA(^PSD(58.8,+PSDNAOU,1,+PSDR,0))
SET PSDRG(+PSDR)=+$PIECE(^(0),U,4)
+3 FOR PSDR=0:0
SET PSDR=$ORDER(PSDRG(PSDR))
if 'PSDR
QUIT
Begin DoDot:1
+4 FOR PSD=PSDSD:0
SET PSD=$ORDER(^PSD(58.81,"ACT",PSD))
if 'PSD
QUIT
Begin DoDot:2
+5 SET PSD58=0
FOR
SET PSD58=$ORDER(^PSD(58.81,"ACT",PSD,PSD58))
if 'PSD58
QUIT
Begin DoDot:3
+6 FOR PSDTYP=0:0
SET PSDTYP=$ORDER(^PSD(58.81,"ACT",PSD,PSD58,PSDR,PSDTYP))
if 'PSDTYP
QUIT
Begin DoDot:4
+7 FOR PSDA=0:0
SET PSDA=$ORDER(^PSD(58.81,"ACT",PSD,PSD58,PSDR,PSDTYP,PSDA))
if 'PSDA
QUIT
IF $PIECE(^PSD(58.81,PSDA,0),U,18)=PSDNAOU!($PIECE(^PSD(58.81,PSDA,0),U,3)=PSDNAOU)
Begin DoDot:5
+8 DO CHK2
+9 if $DATA(^TMP("PSDPAT1",$JOB,PSDR,PSDA))
QUIT
+10 IF $DATA(^PSD(58.81,PSDA,1))
IF $PIECE(^PSD(58.81,PSDA,1),"^",4)<PSDSD
SET PSDSTOP=1
+11 IF $DATA(^PSD(58.81,PSDA,3))
SET PSDSTOP=0
+12 if $GET(PSDSTOP)
QUIT
+13 SET PSDEND=0
IF PSD>PSDED
SET PSDEND=1
+14 SET ^TMP("PSDPAT1",$JOB,PSDR,PSDA)=PSDEND
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 FOR PSDR=0:0
SET PSDR=$ORDER(PSDRG(PSDR))
if 'PSDR
QUIT
Begin DoDot:1
+16 FOR PSD=PSDSD:0
SET PSD=$ORDER(^PSD(58.81,"AK",PSD))
if 'PSD
QUIT
Begin DoDot:2
+17 SET PSDA=0
FOR
SET PSDA=$ORDER(^PSD(58.81,"AK",PSD,PSDNAOU,PSDA))
if 'PSDA
QUIT
Begin DoDot:3
+18 if $PIECE(^PSD(58.81,PSDA,0),"^",5)'=PSDR
QUIT
+19 DO CHK2
+20 if $DATA(^TMP("PSDPAT1",$JOB,PSDR,PSDA))
QUIT
+21 IF $DATA(^PSD(58.81,PSDA,1))
IF $PIECE(^PSD(58.81,PSDA,1),"^",4)<PSDSD
SET PSDSTOP=1
+22 if $GET(PSDSTOP)
QUIT
+23 SET PSDEND=0
IF PSD>PSDED
SET PSDEND=1
+24 SET ^TMP("PSDPAT1",$JOB,PSDR,PSDA)=PSDEND
End DoDot:3
End DoDot:2
End DoDot:1
+25 FOR PSDR=0:0
SET PSDR=$ORDER(PSDRG(PSDR))
if 'PSDR
QUIT
FOR PSDA=0:0
SET PSDA=$ORDER(^PSD(58.8,+PSDNAOU,1,PSDR,3,PSDA))
if 'PSDA
QUIT
Begin DoDot:1
+26 if '$DATA(^PSD(58.8,PSDNAOU,1,PSDR,3,PSDA,0))
QUIT
SET PSD0=^(0)
SET PSD=$PIECE(PSD0,U,15)
+27 IF (PSD>PSDSD)
Begin DoDot:2
+28 SET PSDEND=0
IF PSD>PSDED
SET PSDEND=1
+29 SET PSDTR=+$PIECE($GET(PSD0),U,17)
SET PSDTYP=$PIECE(^PSD(58.81,PSDTR,0),U,2)
SET PSDSTOP=0
IF PSDTYP'=23
DO CHK2
+30 if $GET(PSDSTOP)!($DATA(^TMP("PSDPAT1",$JOB,PSDR,PSDTR)))
QUIT
+31 SET ^TMP("PSDPAT1",$JOB,PSDR,PSDTR)=PSDEND
End DoDot:2
End DoDot:1
+32 FOR PSD=PSDSD:0
SET PSD=$ORDER(^PSD(58.81,"ATRN",PSD))
if 'PSD
QUIT
Begin DoDot:1
+33 FOR PSDA=0:0
SET PSDA=$ORDER(^PSD(58.81,"ATRN",PSD,PSDA))
if 'PSDA
QUIT
Begin DoDot:2
+34 SET PSD0=^PSD(58.81,PSDA,0)
if $PIECE(PSD0,U,18)'=NAOU!('$DATA(PSDRG($PIECE(PSD0,U,5))))
QUIT
Begin DoDot:3
+35 SET PSDEND=0
IF PSD>PSDED
SET PSDEND=1
+36 if $DATA(^TMP("PSDPAT1",$JOB,$PIECE(PSD0,U,5),PSDA))
QUIT
+37 if PSDRG($PIECE(PSD0,U,5))
SET ^TMP("PSDPAT1",$JOB,$PIECE(PSD0,U,5),PSDA)=PSDEND
End DoDot:3
End DoDot:2
End DoDot:1
+38 SET PSDRUG=0
FOR
SET PSDRUG=$ORDER(^TMP("PSDPAT1",$JOB,PSDRUG))
if 'PSDRUG
QUIT
Begin DoDot:1
+39 SET (PSDNBAL,PSDA)=0
FOR
SET PSDA=$ORDER(^TMP("PSDPAT1",$JOB,PSDRUG,PSDA))
if 'PSDA
QUIT
Begin DoDot:2
+40 SET PSD0=$GET(^PSD(58.81,PSDA,0))
SET PSDTYP=$PIECE(PSD0,U,2)
SET PSD=$PIECE(PSD0,U,4)
SET PSDRQ=""
+41 SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(+PSDRUG,0)),U)]"":$PIECE(^(0),U),1:"ZZ/"_PSDRUG_" NAME MISSING")
+42 if $PIECE(PSD0,U,11)=3!($PIECE(PSD0,U,2)=12)
QUIT
+43 SET PSDSTOP=0
IF PSDTYP'=23
DO CHK2
+44 if $GET(PSDSTOP)
QUIT
+45 SET PSDEND=$GET(^TMP("PSDPAT1",$JOB,PSDRUG,PSDA))
+46 IF PSDTYP'=17
SET PSDRQ=$PIECE(^PSD(58.81,PSDA,0),U,20)
if $GET(PSDRQ)
SET PSD0=$GET(^PSD(58.8,PSDNAOU,1,PSDRUG,3,PSDRQ,0))
+47 IF '$GET(PSDRQ)
Begin DoDot:3
+48 SET PSDBAL=$PIECE(PSD0,U,10)
+49 DO SET^PSDPAT2
QUIT
End DoDot:3
QUIT
+50 IF $GET(PSDRQ)
Begin DoDot:3
+51 SET PSD=$PIECE(PSD0,U,15)
+52 if '$GET(PSD)
QUIT
+53 SET PSDNR1=+$PIECE(PSD0,U,7)
SET PSDNR2=""
SET PSDQTY=+$PIECE(PSD0,U,20)
SET PSDBAL=$PIECE(PSD0,U,22)
SET PSDPAT="PHARMACY DISP #"_$PIECE(PSD0,U,16)
+54 SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(+PSDRUG,0)),U)]"":$PIECE(^(0),U),1:"ZZ/"_PSDRUG_" NAME MISSING")
SET PSDTR=+$PIECE($GET(PSD0),U,17)
+55 IF (PSDTYP=18)!(PSDTYP=17)
SET $PIECE(PSDRG(+PSDRUG),U,2)=+$PIECE(PSDRG(+PSDRUG),U,2)+PSDQTY
+56 SET PSDNR1=$SELECT($PIECE($GET(^VA(200,PSDNR1,0)),U)]"":$PIECE(^(0),U),1:"UNKNOWN")
+57 SET (PSDWQT,PSDWRE,PSDRQT,PSDRRE,PSDDRG1,PSDSOQT,PSDDQT,PSDDRE,PSDRET,PSDDT)=""
SET PSD9=""
SET $PIECE(PSD0,U,16)=""
SET PSDTYP=0
+58 SET PSD3=$GET(^PSD(58.81,PSDA,3))
+59 IF $PIECE(^PSD(58.81,PSDA,0),U,2)=9
SET PSDTYP=9
DO SET^PSDPAT2
QUIT
+60 IF $PIECE(^PSD(58.81,PSDA,0),U,2)=5
SET PSDTYP=5
DO SET2^PSDPAT2
QUIT
+61 SET $PIECE(PSD0,U,10)=$PIECE(PSD0,U,22)
DO SET1^PSDPAT2
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+62 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
+63 SET ^TMP("PSDPAT",$JOB,PSDRN,DT,"NO ACTIVITY",1)=0
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,PSDAQTY)=0
SET PSDRN=""
SET $PIECE(LN,"-",132)=""
DO NOW^%DTC
SET Y=+$EXTRACT(%,1,12)
XECUTE ^DD("DD")
SET PSDRPDT=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 PSDPAT=""
FOR
SET PSDPAT=$ORDER(^TMP("PSDPAT",$JOB,PSDRG,PSD,PSDPAT))
if PSDPAT=""!(PSDOUT)
QUIT
FOR PSD1=0:0
SET PSD1=$ORDER(^TMP("PSDPAT",$JOB,PSDRG,PSD,PSDPAT,PSD1))
if 'PSD1!(PSDOUT)
QUIT
Begin DoDot:2
+6 SET (PSDQTY,PSDSOQT,PSDRQT,PSDWQT,PSDDQT,PSDSTAT)=0
SET (PSDRRE,PSDWRE,PSDDRE)=""
+7 SET PSD0=^TMP("PSDPAT",$JOB,PSDRG,PSD,PSDPAT,PSD1)
SET PSDRGN=PSDRG
+8 if $PIECE(PSD0,U,4)=3
QUIT
+9 WRITE !
IF $Y+8>IOSL
DO HDR
if PSDOUT
QUIT
WRITE !,?5,"=> ",PSDRG,!
+10 SET Y=+$EXTRACT(PSD,1,12)
XECUTE ^DD("DD")
SET PSDT=Y
+11 IF $GET(PSD0)=0
SET PSDQTY=0
SET PSDPQT=$PIECE(^TMP("PSDPATL",$JOB,PSDRGN),U,2)
WRITE PSDT,?22,PSDPAT,?55,$JUSTIFY(PSDQTY,6),?75,$JUSTIFY(PSDPQT,6),!
QUIT
+12 SET PSDTYP=+$PIECE(PSD0,U,4)
SET PSDR=$PIECE(PSD0,U,11)
SET PSDSTAT=+$PIECE(PSD0,U,24)
SET PSDQTY=+$PIECE(PSD0,U)
+13 IF (PSDTYP)=9
IF +$PIECE(PSD0,U,5)
Begin DoDot:3
+14 SET PSDPQT=+PSDNBAL+PSDQTY
SET PSDNBAL=PSDPQT
WRITE PSDT,?22,PSDPAT,?45,"*WASTED*",?55,$JUSTIFY(PSDQTY,6),?75,$JUSTIFY(PSDPQT,6),?98,$PIECE(PSD0,U,2),!
+15 SET PSDWQT=+$PIECE(PSD0,U,5)
SET PSDWRE=$PIECE(PSD0,U,6)
SET PSDQTY=PSDQTY-PSDWQT
+16 WRITE ?25,PSDWRE,?55,$JUSTIFY(PSDWQT,6),?98,$PIECE(PSD0,U,3),!
End DoDot:3
+17 IF (PSDTYP)=9
IF '+$PIECE(PSD0,U,5)
SET PSDPQT=+PSDNBAL+PSDQTY
SET PSDNBAL=PSDPQT
WRITE PSDT,?22,PSDPAT,?55,$JUSTIFY(PSDQTY,6),?75,$JUSTIFY(PSDPQT,6),?98,$PIECE(PSD0,U,2),!,?98,$PIECE(PSD0,U,3),!,?25,$PIECE(PSD0,U,6),!
+18 IF PSDTYP=11
SET PSDPQT=+PSDNBAL+PSDQTY
SET PSDNBAL=PSDPQT
WRITE PSDT,?22,PSDPAT,?55,$JUSTIFY(PSDQTY,6),?75,$JUSTIFY(PSDPQT,6),?98,$PIECE(PSD0,U,2),!,?98,$PIECE(PSD0,U,3),!
+19 IF (+$PIECE(PSD0,U,9))
SET PSDRQT=+$PIECE(PSD0,U,9)
+20 IF PSDTYP=17
Begin DoDot:3
+21 SET PSDSOQT=+$PIECE(PSD0,U,12)+$PIECE(PSD0,U,5)
SET PSDNBAL=+(PSDNBAL-PSDSOQT)+PSDRQT
Begin DoDot:4
+22 WRITE PSDT,?22,PSDPAT,?54
if PSDTYP=17
WRITE "-"
WRITE $JUSTIFY(PSDSOQT,6)
+23 WRITE ?75,$JUSTIFY(PSDNBAL,6),?98,$PIECE(PSD0,U,2),!
if $PIECE(PSD0,U,3)'=""
WRITE ?98,$PIECE(PSD0,U,3),!
+24 WRITE PSDT,?22,PSDPAT,?45,"*GIVEN*"
SET PSDQTY=$PIECE(PSD0,U,12)
WRITE ?55,$JUSTIFY(PSDQTY,6),!
+25 IF PSDRQT
SET PSDPRT=1
DO PRTRET
End DoDot:4
End DoDot:3
+26 IF (PSDTYP)'=9
IF +$PIECE(PSD0,U,5)
SET PSDWQT=+$PIECE(PSD0,U,5)
SET PSDWRE=$PIECE(PSD0,U,6)
SET PSDQTY=PSDQTY-PSDWQT
Begin DoDot:3
+27 WRITE PSDT,?22,PSDPAT,?45,"*WASTED*",?55,$JUSTIFY(PSDWQT,6)
+28 WRITE ?98,$PIECE(PSD0,U,2),!,?25,PSDWRE,?98,$PIECE(PSD0,U,3),!
End DoDot:3
+29 IF PSDTYP=23
SET PSDPQT=+PSDNBAL+PSDQTY
SET PSDNBAL=PSDPQT
WRITE PSDT,?22,PSDPAT,?55,$JUSTIFY(PSDQTY,6),?75,$JUSTIFY(PSDPQT,6),?98,$PIECE(PSD0,U,2),!,?98,$PIECE(PSD0,U,3),!
+30 IF PSDTYP=0
IF '$GET(PSDSTAT)
Begin DoDot:3
+31 SET PSDPQT=+PSDNBAL+PSDQTY
SET PSDNBAL=PSDPQT
WRITE PSDT,?22,PSDPAT,?55,$JUSTIFY(PSDQTY,6),?75,$JUSTIFY(PSDPQT,6),?98,$PIECE(PSD0,U,2),!
IF $PIECE(PSD0,U,3)'=""
WRITE ?98,$PIECE(PSD0,U,3),!
+32 SET PSDRQT=+$PIECE(PSD0,U,9)
SET PSDPRT=0
IF $GET(PSDRQT)
DO PRTRET
End DoDot:3
+33 IF PSDTYP=0
IF $GET(PSDSTAT)=10
Begin DoDot:3
+34 SET PSDPQT=+PSDNBAL+$PIECE(PSD0,U)
SET PSDNBAL=PSDPQT
+35 ; < *62 RJS
if $PIECE(PSD0,U)'=0
WRITE PSDT,?22,PSDPAT,?55,$JUSTIFY(PSDQTY,6),?75,$JUSTIFY(PSDPQT,6),?98,$PIECE(PSD0,U,2),!,?98,$PIECE(PSD0,U,3),!
+36 SET PSDTFDT=$PIECE(PSD0,U,17)
SET Y=PSDTFDT
XECUTE ^DD("DD")
SET PSDTFDT=$EXTRACT(Y,1,17)
SET PSDTFN=$PIECE(PSD0,U,18)
SET PSDT2N=$PIECE(PSD0,U,19)
SET PSDTTDT=$PIECE(PSD0,U,20)
+37 SET PSDTTNR=$PIECE(PSD0,U,21)
SET PSDTRQT=+$PIECE(PSD0,U,23)
SET PSDNBAL=+PSDNBAL-PSDTRQT
DO PRTTRT
End DoDot:3
+38 IF PSDTYP=5
IF '$GET(PSDSTAT)
SET PSDPQT=+PSDNBAL+PSDQTY
SET PSDNBAL=PSDPQT
Begin DoDot:3
+39 WRITE PSDT,?22,PSDPAT,?45,"*TRFER*",?55,$JUSTIFY(PSDQTY,6),?75,$JUSTIFY(PSDPQT,6),?98,$PIECE(PSD0,U,2),!
IF $PIECE(PSD0,U,3)'=""
WRITE ?98,$PIECE(PSD0,U,3),!
+40 WRITE ?29,"*TRANSFERED FROM "_$PIECE(PSD0,U,19),"*",?98,$PIECE(PSD0,U,21)
+41 SET PSDRQT=+$PIECE(PSD0,U,9)
IF $GET(PSDRQT)
Begin DoDot:4
+42 SET PSDRRE=$PIECE(PSD0,U,10)
SET PSDNBAL=+PSDNBAL-PSDRQT
SET PSDRET=$PIECE(PSD0,U,15)
SET Y=PSDRET
XECUTE ^DD("DD")
SET PSDRET=$EXTRACT(Y,1,17)
+43 if $GET(PSDRET)=0
SET PSDRET=""
WRITE !,PSDRET,?22,PSDPAT,?45,"*RETURN* -",?55,$JUSTIFY(PSDRQT,6),?75,$JUSTIFY(PSDNBAL,6),?98,$PIECE(PSD0,U,2),!,?25,PSDRRE,?98,!
End DoDot:4
End DoDot:3
+44 IF +$PIECE(PSD0,U,13)
SET PSDDQT=+$PIECE(PSD0,U,13)
SET PSDDRE=$PIECE(PSD0,U,14)
SET PSDDT=+$PIECE(PSD0,U,16)
SET PSDNBAL=PSDNBAL-PSDDQT
Begin DoDot:3
+45 WRITE PSDT,?22,PSDPAT,?44,"*DESTROY* -",?55,$JUSTIFY(PSDDQT,6),?75,$JUSTIFY(PSDNBAL,6),?98,$PIECE(PSD0,U,2),!,?25,PSDDRE,?98,$PIECE(PSD0,U,3),!
End DoDot:3
+46 IF PSDTYP=5
IF $GET(PSDSTAT)=10
Begin DoDot:3
+47 SET PSDPQT=+PSDNBAL+$PIECE(PSD0,U)-$PIECE(PSD0,U,23)
SET PSDNBAL=PSDPQT
+48 ; < *62 RJS
if $PIECE(PSD0,U)'=""
WRITE PSDT,?22,PSDPAT,?55,$JUSTIFY(PSDQTY,6),?75,$JUSTIFY(PSDPQT,6),?98,$PIECE(PSD0,U,2),!,?98,$PIECE(PSD0,U,3),!
+49 SET PSDTFDT=$PIECE(PSD0,U,17)
SET Y=PSDTFDT
XECUTE ^DD("DD")
SET PSDTFDT=$EXTRACT(Y,1,17)
SET PSDTFN=$PIECE(PSD0,U,18)
SET PSDT2N=$PIECE(PSD0,U,19)
SET PSDTTDT=$PIECE(PSD0,U,20)
+50 SET PSDTTNR=$PIECE(PSD0,U,21)
SET PSDTRQT=+$PIECE(PSD0,U,23)
DO PRTTRT
End DoDot:3
+51 IF PSDTYP=99
IF +$PIECE(PSD0,U,9)'=0
Begin DoDot:3
+52 SET PSDRQT=+$PIECE(PSD0,U,9)
SET PSDNBAL=+PSDNBAL-PSDRQT
DO PRTRET
End DoDot:3
End DoDot:2
if PSDOUT
QUIT
End DoDot:1
if PSDOUT
QUIT
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,%,%DT,%H,%I,%ZIS,ALL,PSDAQTY,PSDBAL,PSDCNT,DA,PSDT,PSDDT,DFN,DIC,DIR,DIROUT,DIRUT,PSDDQT,DTOUT,PSDDRE,PSDDRG1,DUOUT,LN,LOOP,PSDNAOU,NAOU,NAOUN,PSDNBAL,PSD0,PSD3,PSD7,PSD9,PSDNR1,PSDSTOP
+2 KILL PSDNR2,PSDSTAT,PSDPAT,PG,POP,PSD,PSD1,PSDA,PSDATE,PSDED,PSDOUT,PSDPN,PSDPQT,PSDR,PSDRET,PSDRG,PSDRGN,PSDRN,PSDSD,PSDRQT,PSDRRE,PSDRPDT,PSDSOQT,PSD58,PSDRQ,PSDRUG,PSDTBAL,PSDTMP,PSDEND,PSDT2N,PSDTFDT,PSDPRT
+3 KILL PSDTFN,PSDTPRV,PSDTR,PSDTRQT,PSDTTDT,PSDTTNR,PSDTTON,PSDTQTY,PSDTYP,PSDQTY,SUM,PSDUQT,VADM,VAERR,PSDWQT,PSDWRE,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK,^TMP("PSDPAT",$JOB),^TMP("PSDPAT1",$JOB),^TMP("PSDPATB",$JOB),^TMP("PSDPATL",$JOB)
+4 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
PRTTRT ; PRINT TRANSFER TO INFORMATION
+1 WRITE PSDTFDT,?22,PSDPAT,?45,"*TRFER* -",?55,$JUSTIFY(PSDTRQT,6),?75,$JUSTIFY(PSDNBAL,6),?98,$PIECE(PSD0,U,18),!,?32,"*TRANSFER TO "_$PIECE(PSD0,U,19),"*",?98,$PIECE(PSD0,U,21),!
+2 QUIT
PRTRET ; PRINT RETURN INFORMATION
+1 SET PSDRRE=$PIECE(PSD0,U,10)
SET PSDRET=$PIECE(PSD0,U,15)
SET Y=PSDRET
XECUTE ^DD("DD")
SET PSDRET=$EXTRACT(Y,1,17)
+2 if $GET(PSDRET)=0
SET PSDRET=""
SET PSDNBAL=+PSDNBAL-PSDRQT
+3 WRITE PSDRET,?22,PSDPAT,?45,"*RETURN*"
if '$GET(PSDPRT)
WRITE " -"
WRITE ?55,$JUSTIFY(PSDRQT,6)
if '$GET(PSDPRT)
WRITE ?75,$JUSTIFY(PSDNBAL,6)
+4 WRITE ?98,$PIECE(PSD0,U,2),!,?25,PSDRRE,?98,$PIECE(PSD0,U,3),!
+5 KILL PSDPRT
+6 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,PSDRPDT,?115,"Page: ",PG,!,?20,"Date: ",$PIECE(PSDATE,U)," to ",$PIECE(PSDATE,U,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 PSDTQTY=+$GET(^TMP("PSDPATL",$JOB,PSDRG))
SET PSDBAL=+$PIECE($GET(^TMP("PSDPATL",$JOB,PSDRG)),U,2)
SET PSDUQT=PSDBAL-PSDTQTY
SET PSDNBAL=$PIECE($GET(^TMP("PSDPATL",$JOB,PSDRG)),U,2)-$PIECE($GET(^TMP("PSDPATL",$JOB,PSDRG)),U,1)
+2 QUIT
CHK2 ;CHECK THE TTYPE
+1 SET PSDSTOP=0
IF PSDTYP'=23
Begin DoDot:1
+2 IF '$DATA(^PSD(58.81,PSDA,1))
Begin DoDot:2
+3 IF PSDTYP'=17
SET PSDSTOP=1
+4 IF PSDTYP=9
SET PSDSTOP=0
End DoDot:2
End DoDot:1
+5 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(PSDAQTY,6),?70,$J(PSDPQT,6),!
+3 WRITE !
SET PSDAQTY=0
+4 QUIT
