source: FOIAVistA/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDPAT1.m@ 1801

Last change on this file since 1801 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 9.4 KB
Line 
1PSDPAT1 ;B'ham ISC/JPW,BJW - Prt activity report (Patient/Drug) ; 17 Apr 98
2 ;;3.0; CONTROLLED SUBSTANCES ;**7,62**;13 Feb 97;Build 3
3 ;modified for nois:det-0198-42285;displays drugs for destruction,returns,waste,transfers
4START ;entry for compile and print
5 K ^TMP("PSDPAT",$J) S (AQTY,CNT)=0
6 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)
7 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
8 .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
9 ;; *62 RJS>
10 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
11 .Q:'$D(^PSD(58.8,NAOU,1,PSDR,3,PSDA,0)) S NODE=^(0),PSD=$P(NODE,"^",15)
12 .I (PSD>PSDSD),(PSD<PSDED) D
13 ..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)
14 ..I (TYP=18)!(TYP=17) S $P(PSDRG(+PSDR),"^",2)=+$P(PSDRG(+PSDR),"^",2)+QTY
15 ..S NUR1=$S($P($G(^VA(200,NUR1,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
16 ..S (WQTY,WREAS,RQTY,RREAS,DRUGNO,SOQTY,DQTY,DREAS,PSDRET,DDATE)=""
17 ..S NODE9="",$P(NODE,U,16)="",TYP=0
18 ..S $P(NODE,U,10)=$P(NODE,U,22) D SET1
19 ;; *62 RJS>
20 F PSD=PSDSD:0 S PSD=$O(^PSD(58.81,"ATRN",PSD)) Q:'PSD!(PSD>PSDED) D
21 .F PSDA=0:0 S PSDA=$O(^PSD(58.81,"ATRN",PSD,PSDA)) Q:'PSDA D
22 ..S NODE=^PSD(58.81,PSDA,0) Q:$P(NODE,U,18)'=NAOU!('$D(PSDRG($P(NODE,U,5)))) D SET2
23 ;; <*62 RJS
24 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))
25 .S ^TMP("PSDPAT",$J,PSDRN,DT,"NO ACTIVITY",1)=0
26 .S ^TMP("PSDPATL",$J,PSDRN)=U_PSDRG(PSDR)
27PRINT ;prints data
28 I SUM="S" D ^PSDPAT2 G DONE
29 S (PG,PSDOUT,AQTY)=0,PSDRN="",$P(LN,"-",132)="" D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S RPDT=Y
30 I '$D(^TMP("PSDPAT",$J)) D HDR W !!,?15,"**** NO DISPENSING ACTIVITY ****",!! G DONE
31 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
32 .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
33 ..S (QTY,SOQTY,RQTY,WQTY,DQTY,NEWBAL,ORDST)=0,(RREAS,WREAS,DREAS)=""
34 ..S NODE=^TMP("PSDPAT",$J,PSDRG,PSD,PAT,PSD1),PSDRGN=PSDRG
35 ..Q:$P(NODE,U,4)=3
36 ..W !
37 ..I $Y+8>IOSL D HDR Q:PSDOUT W !,?5,"=> ",PSDRG,!
38 ..S Y=+$E(PSD,1,12) X ^DD("DD") S DATE=Y
39 ..S TYP=+$P(NODE,"^",4),PSDR=$P(NODE,"^",11),ORDST=+$P(NODE,"^",24)
40 ..S QTY=+$P(NODE,"^")
41 ..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),!
42 ..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),!
43 ..I TYP=17 S SOQTY=+$P(NODE,"^",12),NEWBAL=+$P(NODE,"^",7)-SOQTY D
44 ...W DATE,?22,PAT,?54 W:TYP=17 "-" W $J(SOQTY,6)
45 ...W ?75,$J(NEWBAL,6),?98,$P(NODE,"^",2),!,?98,$P(NODE,"^",3),!
46 ..I (TYP=17),(+$P(NODE,"^",9)) S RQTY=+$P(NODE,"^",9) D
47 ...S RREAS=$P(NODE,"^",10),NEWBAL=+NEWBAL+RQTY,PSDRET=$P(NODE,"^",15),Y=PSDRET X ^DD("DD") S PSDRET=$E(Y,1,17)
48 ...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),!
49 ..I +$P(NODE,U,5) S WQTY=+$P(NODE,U,5),WREAS=$P(NODE,"^",6),QTY=QTY-WQTY D
50 ...W DATE,?22,PAT,?45,"*WASTED*",?55,$J(WQTY,6)
51 ...W ?98,$P(NODE,"^",2),!,?25,WREAS,?98,$P(NODE,"^",3),!
52 ..I +$P(NODE,U,13) S DQTY=+$P(NODE,U,13),DREAS=$P(NODE,U,14),DDATE=+$P(NODE,U,16) D
53 ...W DATE,?22,PAT,?45,"*DESTROY*",?55,$J(DQTY,6),?98,$P(NODE,"^",2),!,?25,DREAS,?98,$P(NODE,"^",3),!
54 ..W:TYP=17 DATE,?22,PAT,?45,"*GIVEN*",?55,$J(QTY,6),!
55 ..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),!
56 ..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),!
57 ..I TYP=0,$G(ORDST)=10 D ; *62 RJS .
58 ...S PQTY=+$P(NODE,"^")+$P(NODE,"^",7)+$P(NODE,"^",23),NEWBAL=PQTY
59 ...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
60 ... 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)
61 ...S TTNUR=$P(NODE,"^",21),TRQTY=+$P(NODE,"^",23),NEWBAL=+NEWBAL-TRQTY
62 ...W TFDTE,?22,PAT,?45,"*TRFER*",?54 W:TYP=0 "-" W $J(TRQTY,6),?75,$J(NEWBAL,6)
63 ...W ?98,$P(NODE,"^",18),!,?32,"*TRANSFER TO "_$P(NODE,"^",19),"*",?98,$P(NODE,"^",21)
64 ;..W:$P(NODE,U,8) " recorded by ",$P($G(^VA(200,$P(NODE,U,8),0)),U)
65DONE I $E(IOST)'="C" W @IOF
66 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
67END ;
68 D KVAR^VADPT K VA
69 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
70 K PAT,PG,POP,PSD,PSD1,PSDA,PSDATE,PSDED,PSDOUT,PSDPN,PQTY,PSDR,PSDRET,PSDRG,PSDRGN,PSDRN,PSDSD,RQTY,RREAS,RPDT,SOQTY
71 K T2NAOU,TFDTE,TFNUR,TPRVTR,TRQTY,TTDTE,TTNUR,TTONAOU,TQTY,TYP,QTY,SUM,UQTY,VADM,VAERR,WQTY,WREAS,X,Y
72 K ^TMP("PSDPAT",$J),^TMP("PSDPATL",$J),ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
73 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
74 Q
75SET ;sets data
76 ;Q:TYP=11
77 Q:'$D(^PSD(58.81,PSDA,0)) S NODE=^(0),QTY=+$P(NODE,"^",6)
78 S NODE9=$G(^PSD(58.81,PSDA,9)) S SOQTY=+$P(NODE9,"^",3),WQTY=+$P(NODE9,"^",4)
79 I +$P(NODE,"^",5) S DRUGNO=+$P(NODE,"^",5)
80 I TYP=17 S $P(PSDRG(+PSDR),"^",2)=+$P(PSDRG(+PSDR),"^",2)+SOQTY
81 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)
82 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")
83 S NUR1=$S($P(NODE9,U,2):$P(NODE9,U,2),1:$P(NODE,U,7))
84 S:NUR1'=$P(NODE,U,7) NUR1(1)=$P(NODE,U,7)
85 ;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))
86 S NUR1=$S($P($G(^VA(200,+NUR1,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
87 S NUR2=$P($G(NODE9),"^",6) S:NUR2 NUR2=$S($P($G(^VA(200,+NUR2,0)),"^")]"":$P(^(0),"^"),1:"")
88 S PSDRN=$S($P($G(^PSDRUG(+PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR_" NAME MISSING")
89 ;I +$P(NODE9,"^",4) S QTY=+$P(NODE9,"^",4)
90 ;I +$P(NODE9,"^",7) S QTY=+$P(NODE9,"^",7)-$P(NODE9,"^",3)
91 ;I +$P(NODE9,"^",5) S QTY=+$P(NODE9,"^",5)
92 ;12/9/97 added next line;added to tmp-file
93SET1 ;sets ^tmp
94 I TYP=0 D CHKNOD7
95 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
96 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
97 S:'$D(^TMP("PSDPATL",$J,PSDRN)) ^TMP("PSDPATL",$J,PSDRN)=0
98 S ^TMP("PSDPATL",$J,PSDRN)=+^TMP("PSDPATL",$J,PSDRN)+($S(TYP=18:-QTY,TYP=17:-SOQTY,1:QTY)),$P(^(PSDRN),"^",2)=+PSDRG(PSDR)
99 S $P(^TMP("PSDPATL",$J,PSDRN),"^",3)=+$P(^TMP("PSDPATL",$J,PSDRN),"^",3)+$P(PSDRG(+PSDR),"^",2)
100 K QTY,NUR1,NUR2,NODE,NODE3,NODE7,PSDTR Q
101SET2 ;SETS TRANSFER DATA ONLY ;; *62 RJS >
102 N PSDTRDT,PAT
103 S PSDR=$P(NODE,U,5),PSDRN=$S($P($G(^PSDRUG(+PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR_" NAME MISSING")
104 S PSDTRDT=$P(^PSD(58.81,PSDA,1),U,4)
105 Q:$D(^TMP("PSDPAT",$J,PSDRN,PSDTRDT))
106 S PSDTR=PSDA D CHKNOD7
107 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
108 S:'$D(^TMP("PSDPATL",$J,PSDRN)) ^TMP("PSDPATL",$J,PSDRN)=0
109 S $P(^TMP("PSDPATL",$J,PSDRN),"^",3)=+$P(^TMP("PSDPATL",$J,PSDRN),"^",3)+$P(PSDRG(+PSDR),"^",2)
110 K QTY,NUR1,NUR2,NODE,NODE3,NODE7,PSDTR
111 Q ; < *62 RJS
112CHKNOD7 ;
113 S NODE7=$G(^PSD(58.81,+PSDTR,7))
114 S ORDST=$P($G(^PSD(58.81,+PSDTR,0)),"^",11)
115 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)
116 S TFNUR=$S($P(NODE7,U,2):$P(NODE7,U,2),1:$P(NODE,U,7))
117 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")
118 S TTNUR=$P($G(NODE7),"^",5) S:TTNUR TTNUR=$S($P($G(^VA(200,+TTNUR,0)),"^")]"":$P(^(0),"^"),1:"")
119 Q
120HDR ;header
121 I $E(IOST,1,2)="C-",PG K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
122 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),!!
123 W ?5,"=> DRUG",!,"DATE/TIME",?22,"PATIENT",?55,"QUANTITY",?75,"BALANCE",?98,"NURSE 1",!,?98,"NURSE2",!,LN,!!
124 Q
125CHK ;sets total qty used and balance
126 S TQTY=+$G(^TMP("PSDPATL",$J,PSDRG)),BAL=+$P($G(^TMP("PSDPATL",$J,PSDRG)),"^",2),UQTY=BAL-TQTY
127 Q
128TOT ;prints total qty used and balance
129 I $Y+4>IOSL D HDR Q:PSDOUT W !,?5,"=> ",$S(PSDRG]"":PSDRG,1:PSDRGN),!
130 ;W !,?55,"----------",?75,"----------",!,?5,"Total Quantity Used and Balance",?55,$J(AQTY,6),?70,$J(PQTY,6),!
131 W ! S AQTY=0
132 Q
Note: See TracBrowser for help on using the repository browser.