Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSDPAT1

PSDPAT1.m

Go to the documentation of this file. 
  1. 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
  1.  ;modified for nois:det-0198-42285;displays drugs for destruction,returns,waste,transfers
  1. START ;entry for compile and print
  1.  K ^TMP("PSDPAT",$J) S (AQTY,CNT)=0
  1.  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)
  1.  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
  1.  .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
  1.  ;; *62 RJS>
  1.  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
  1.  .Q:'$D(^PSD(58.8,NAOU,1,PSDR,3,PSDA,0))  S NODE=^(0),PSD=$P(NODE,"^",15)
  1.  .I (PSD>PSDSD),(PSD<PSDED) D
  1.  ..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)
  1.  ..I (TYP=18)!(TYP=17) S $P(PSDRG(+PSDR),"^",2)=+$P(PSDRG(+PSDR),"^",2)+QTY
  1.  ..S NUR1=$S($P($G(^VA(200,NUR1,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
  1.  ..S (WQTY,WREAS,RQTY,RREAS,DRUGNO,SOQTY,DQTY,DREAS,PSDRET,DDATE)=""
  1.  ..S NODE9="",$P(NODE,U,16)="",TYP=0
  1.  ..S $P(NODE,U,10)=$P(NODE,U,22) D SET1
  1.  ;; *62 RJS>
  1.  F PSD=PSDSD:0 S PSD=$O(^PSD(58.81,"ATRN",PSD)) Q:'PSD!(PSD>PSDED)  D
  1.  .F PSDA=0:0 S PSDA=$O(^PSD(58.81,"ATRN",PSD,PSDA)) Q:'PSDA  D
  1.  ..S NODE=^PSD(58.81,PSDA,0) Q:$P(NODE,U,18)'=NAOU!('$D(PSDRG($P(NODE,U,5))))  D SET2
  1.  ;; <*62 RJS
  1.  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))
  1.  .S ^TMP("PSDPAT",$J,PSDRN,DT,"NO ACTIVITY",1)=0
  1.  .S ^TMP("PSDPATL",$J,PSDRN)=U_PSDRG(PSDR)
  1. PRINT ;prints data
  1.  I SUM="S" D ^PSDPAT2 G DONE
  1.  S (PG,PSDOUT,AQTY)=0,PSDRN="",$P(LN,"-",132)="" D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S RPDT=Y
  1.  I '$D(^TMP("PSDPAT",$J)) D HDR W !!,?15,"**** NO DISPENSING ACTIVITY ****",!! G DONE
  1.  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
  1.  .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
  1.  ..S (QTY,SOQTY,RQTY,WQTY,DQTY,NEWBAL,ORDST)=0,(RREAS,WREAS,DREAS)=""
  1.  ..S NODE=^TMP("PSDPAT",$J,PSDRG,PSD,PAT,PSD1),PSDRGN=PSDRG
  1.  ..Q:$P(NODE,U,4)=3
  1.  ..W !
  1.  ..I $Y+8>IOSL D HDR Q:PSDOUT  W !,?5,"=> ",PSDRG,!
  1.  ..S Y=+$E(PSD,1,12) X ^DD("DD") S DATE=Y
  1.  ..S TYP=+$P(NODE,"^",4),PSDR=$P(NODE,"^",11),ORDST=+$P(NODE,"^",24)
  1.  ..S QTY=+$P(NODE,"^")
  1.  ..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),!
  1.  ..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),!
  1.  ..I TYP=17 S SOQTY=+$P(NODE,"^",12),NEWBAL=+$P(NODE,"^",7)-SOQTY D
  1.  ...W DATE,?22,PAT,?54 W:TYP=17 "-" W $J(SOQTY,6)
  1.  ...W ?75,$J(NEWBAL,6),?98,$P(NODE,"^",2),!,?98,$P(NODE,"^",3),!
  1.  ..I (TYP=17),(+$P(NODE,"^",9)) S RQTY=+$P(NODE,"^",9) D
  1.  ...S RREAS=$P(NODE,"^",10),NEWBAL=+NEWBAL+RQTY,PSDRET=$P(NODE,"^",15),Y=PSDRET X ^DD("DD") S PSDRET=$E(Y,1,17)
  1.  ...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),!
  1.  ..I +$P(NODE,U,5) S WQTY=+$P(NODE,U,5),WREAS=$P(NODE,"^",6),QTY=QTY-WQTY D
  1.  ...W DATE,?22,PAT,?45,"*WASTED*",?55,$J(WQTY,6)
  1.  ...W ?98,$P(NODE,"^",2),!,?25,WREAS,?98,$P(NODE,"^",3),!
  1.  ..I +$P(NODE,U,13) S DQTY=+$P(NODE,U,13),DREAS=$P(NODE,U,14),DDATE=+$P(NODE,U,16) D
  1.  ...W DATE,?22,PAT,?45,"*DESTROY*",?55,$J(DQTY,6),?98,$P(NODE,"^",2),!,?25,DREAS,?98,$P(NODE,"^",3),!
  1.  ..W:TYP=17 DATE,?22,PAT,?45,"*GIVEN*",?55,$J(QTY,6),!
  1.  ..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),!
  1.  ..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),!
  1.  ..I TYP=0,$G(ORDST)=10 D  ; *62 RJS .
  1.  ...S PQTY=+$P(NODE,"^")+$P(NODE,"^",7)+$P(NODE,"^",23),NEWBAL=PQTY
  1.  ...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
  1.  ... 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)
  1.  ...S TTNUR=$P(NODE,"^",21),TRQTY=+$P(NODE,"^",23),NEWBAL=+NEWBAL-TRQTY
  1.  ...W TFDTE,?22,PAT,?45,"*TRFER*",?54 W:TYP=0 "-" W $J(TRQTY,6),?75,$J(NEWBAL,6)
  1.  ...W ?98,$P(NODE,"^",18),!,?32,"*TRANSFER TO "_$P(NODE,"^",19),"*",?98,$P(NODE,"^",21)
  1.  ;..W:$P(NODE,U,8) " recorded by ",$P($G(^VA(200,$P(NODE,U,8),0)),U)
  1. DONE I $E(IOST)'="C" W @IOF
  1.  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
  1. END ;
  1.  D KVAR^VADPT K VA
  1.  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
  1.  K PAT,PG,POP,PSD,PSD1,PSDA,PSDATE,PSDED,PSDOUT,PSDPN,PQTY,PSDR,PSDRET,PSDRG,PSDRGN,PSDRN,PSDSD,RQTY,RREAS,RPDT,SOQTY
  1.  K T2NAOU,TFDTE,TFNUR,TPRVTR,TRQTY,TTDTE,TTNUR,TTONAOU,TQTY,TYP,QTY,SUM,UQTY,VADM,VAERR,WQTY,WREAS,X,Y
  1.  K ^TMP("PSDPAT",$J),^TMP("PSDPATL",$J),ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
  1.  D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
  1.  Q
  1. SET ;sets data
  1.  ;Q:TYP=11
  1.  Q:'$D(^PSD(58.81,PSDA,0))  S NODE=^(0),QTY=+$P(NODE,"^",6)
  1.  S NODE9=$G(^PSD(58.81,PSDA,9)) S SOQTY=+$P(NODE9,"^",3),WQTY=+$P(NODE9,"^",4)
  1.  I +$P(NODE,"^",5) S DRUGNO=+$P(NODE,"^",5)
  1.  I TYP=17 S $P(PSDRG(+PSDR),"^",2)=+$P(PSDRG(+PSDR),"^",2)+SOQTY
  1.  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)
  1.  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")
  1.  S NUR1=$S($P(NODE9,U,2):$P(NODE9,U,2),1:$P(NODE,U,7))
  1.  S:NUR1'=$P(NODE,U,7) NUR1(1)=$P(NODE,U,7)
  1.  ;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))
  1.  S NUR1=$S($P($G(^VA(200,+NUR1,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
  1.  S NUR2=$P($G(NODE9),"^",6) S:NUR2 NUR2=$S($P($G(^VA(200,+NUR2,0)),"^")]"":$P(^(0),"^"),1:"")
  1.  S PSDRN=$S($P($G(^PSDRUG(+PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR_" NAME MISSING")
  1.  ;I +$P(NODE9,"^",4) S QTY=+$P(NODE9,"^",4)
  1.  ;I +$P(NODE9,"^",7) S QTY=+$P(NODE9,"^",7)-$P(NODE9,"^",3)
  1.  ;I +$P(NODE9,"^",5) S QTY=+$P(NODE9,"^",5)
  1.  ;12/9/97 added next line;added to tmp-file
  1. SET1 ;sets ^tmp
  1.  I TYP=0 D CHKNOD7
  1.  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
  1.  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
  1.  S:'$D(^TMP("PSDPATL",$J,PSDRN)) ^TMP("PSDPATL",$J,PSDRN)=0
  1.  S ^TMP("PSDPATL",$J,PSDRN)=+^TMP("PSDPATL",$J,PSDRN)+($S(TYP=18:-QTY,TYP=17:-SOQTY,1:QTY)),$P(^(PSDRN),"^",2)=+PSDRG(PSDR)
  1.  S $P(^TMP("PSDPATL",$J,PSDRN),"^",3)=+$P(^TMP("PSDPATL",$J,PSDRN),"^",3)+$P(PSDRG(+PSDR),"^",2)
  1.  K QTY,NUR1,NUR2,NODE,NODE3,NODE7,PSDTR Q
  1. SET2 ;SETS TRANSFER DATA ONLY  ;; *62 RJS >
  1.  N PSDTRDT,PAT
  1.  S PSDR=$P(NODE,U,5),PSDRN=$S($P($G(^PSDRUG(+PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR_" NAME MISSING")
  1.  S PSDTRDT=$P(^PSD(58.81,PSDA,1),U,4)
  1.  Q:$D(^TMP("PSDPAT",$J,PSDRN,PSDTRDT))
  1.  S PSDTR=PSDA D CHKNOD7
  1.  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
  1.  S:'$D(^TMP("PSDPATL",$J,PSDRN)) ^TMP("PSDPATL",$J,PSDRN)=0
  1.  S $P(^TMP("PSDPATL",$J,PSDRN),"^",3)=+$P(^TMP("PSDPATL",$J,PSDRN),"^",3)+$P(PSDRG(+PSDR),"^",2)
  1.  K QTY,NUR1,NUR2,NODE,NODE3,NODE7,PSDTR
  1.  Q  ; < *62 RJS
  1. CHKNOD7 ;
  1.  S NODE7=$G(^PSD(58.81,+PSDTR,7))
  1.  S ORDST=$P($G(^PSD(58.81,+PSDTR,0)),"^",11)
  1.  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)
  1.  S TFNUR=$S($P(NODE7,U,2):$P(NODE7,U,2),1:$P(NODE,U,7))
  1.  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")
  1.  S TTNUR=$P($G(NODE7),"^",5) S:TTNUR TTNUR=$S($P($G(^VA(200,+TTNUR,0)),"^")]"":$P(^(0),"^"),1:"")
  1.  Q
  1. HDR ;header
  1.  I $E(IOST,1,2)="C-",PG K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
  1.  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),!!
  1.  W ?5,"=>  DRUG",!,"DATE/TIME",?22,"PATIENT",?55,"QUANTITY",?75,"BALANCE",?98,"NURSE 1",!,?98,"NURSE2",!,LN,!!
  1.  Q
  1. CHK ;sets total qty used and balance
  1.  S TQTY=+$G(^TMP("PSDPATL",$J,PSDRG)),BAL=+$P($G(^TMP("PSDPATL",$J,PSDRG)),"^",2),UQTY=BAL-TQTY
  1.  Q
  1. TOT ;prints total qty used and balance
  1.  I $Y+4>IOSL D HDR Q:PSDOUT  W !,?5,"=> ",$S(PSDRG]"":PSDRG,1:PSDRGN),!
  1.  ;W !,?55,"----------",?75,"----------",!,?5,"Total Quantity Used and Balance",?55,$J(AQTY,6),?70,$J(PQTY,6),!
  1.  W ! S AQTY=0
  1.  Q