source: WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDCOSH.m@ 1800

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

initial load of WorldVistAEHR

File size: 3.3 KB
RevLine 
[613]1PSDCOSH ;BIR/LTL-Cost Report by High Cost, PSDCOST (cont'd) ; 2 Aug 94
2 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
3 N PSDN,LN,PG,X2 S PSDSD(1)=PSDSD S:$D(ZTQUEUED) ZTREQ="@"
4 F S PSDSD=$O(^PSD(58.81,"ACT",PSDSD)) W:$E(IOST)="C" "." Q:'PSDSD!(PSDSD>PSDED) S PSDN=$O(^PSD(58.81,"ACT",PSDSD,0)) D:$P($G(^PSD(58.8,+PSDN,0)),U,3)=+PSDSITE
5 .S PSDN(1)=$O(^PSD(58.81,"ACT",PSDSD,PSDN,0))
6 .S PSDN(2)=$O(^PSD(58.81,"ACT",PSDSD,PSDN,PSDN(1),0))
7 .Q:PSDN(2)<2!(PSDN(2)>5)&(PSDN(2)'=9)
8 .S PSDN(3)=$P($G(^PSDRUG(+PSDN(1),0)),U)
9 .S PSDN(4)=$O(^PSD(58.81,"ACT",PSDSD,PSDN,PSDN(1),PSDN(2),0))
10 .S PSDN(8)=$G(^PSD(58.81,+PSDN(4),0))
11 .Q:'$D(LOC(+$P(PSDN(8),U,18)))&(PSDN(2)'=9)!('$D(LOC(+PSDN))&(PSDN(2)=9))
12 .;get NAOU for everything including adjustments
13 .S PSDN(9)=$S(PSDN(2)=9:PSDN,1:$P(PSDN(8),U,18))
14 .;qty rec'd by NAOU w/green sheet
15 .S PSDN(5)=$P($G(^PSD(58.81,+PSDN(4),1)),U,8)
16 .;qty dispensed by Master Vault w/o green sheet
17 .S:$P(PSDN(8),U,17)']"" PSDN(5)=$P(PSDN(8),U,6)
18 .;Returned to Stock
19 .S:PSDN(2)=3 PSDN(5)=-$P($G(^PSD(58.81,+PSDN(4),3)),U,2)
20 .;Destroyed
21 .S:PSDN(2)=4 PSDN(5)=-$P($G(^PSD(58.81,+PSDN(4),3)),U,5)
22 .;include transfer ins with dispensed
23 .S:PSDN(2)=5 PSDN(2)=2
24 .;Check for transfers
25 .S PSDN(6)=$G(^PSD(58.81,+PSDN(4),7))
26 .D:$P(PSDN(6),U)>PSDSD(1)&($P(PSDN(6),U)<PSDED)
27 ..S PSDN(5)=PSDN(5)-$P(PSDN(6),U,7),PSDN(2)=5
28 .S PSDN(7)=$G(^TMP("PSD",$J,PSDN(3)))
29 .;total dispensed
30 .S $P(^TMP("PSD",$J,PSDN(3)),U)=$P(PSDN(7),U)+PSDN(5)
31 .;total cost
32 .S $P(^TMP("PSD",$J,PSDN(3)),U,2)=$P(^TMP("PSD",$J,PSDN(3)),U,2)+($P($G(^PSDRUG(+PSDN(1),660)),U,6)*PSDN(5))
33 .K PSDN
34PRTQUE ;queues print after data is compiled
35 I $D(ZTQUEUED) K ZTSAVE,ZTSK S ZTIO=PSDIO,ZTDESC="CS High Cost Report",ZTRTN="START^PSDCOSH",ZTDTH=$H,ZTSAVE("PSD*")="",ZTSAVE("^TMP(""PSD"",$J,")="",ZTSAVE("ALL")="",ZTSAVE("LOC(")="" D ^%ZTLOAD,HOME^%ZIS G QUIT
36START S (PG,PSDN)=0 D HEADER
37 D:PSD(1)=1
38 .F S PSDN=$O(^TMP("PSD",$J,PSDN)) Q:PSDN!(PSDN']"") S PSDN(1)=$G(^TMP("PSD",$J,PSDN)) D:$P(PSDN(1),U,2)>PSD
39 ..S ^TMP("PSD",$J,999999999-$P(PSDN(1),U,2))=$P(PSDN(1),U)_U_$P(PSDN(1),U,2)_U_PSDN
40 F S PSDN=$O(^TMP("PSD",$J,PSDN)) Q:(PSD(1)=1&('PSDN))!(PSDN']"") D:$Y+6>IOSL HEADER G:$G(PSDOUT) END D G:$G(PSDOUT) END
41 .S PSDN(1)=$G(^TMP("PSD",$J,PSDN))
42 .Q:PSD(1)=2&($P(PSDN(1),U,2)'>PSD)
43 .W $E($S(PSDN:$P(PSDN(1),U,3),1:PSDN),1,34),?36
44 .W $J($P(PSDN(1),U),10),?62
45 .S X=$P(PSDN(1),U,2),X2="2$" D COMMA^%DTC W X,!!
46 W:'$O(^TMP("PSD",$J,0)) !!,"Sorry, nothing to report for selected NAOU(s).",!!
47END W:$E(IOST)'="C" @IOF
48 I $E(IOST)="C",'$G(PSDOUT) W !! S DIR(0)="EA",DIR("A")="END OF REPORT! Press <RET> to return to the menu." D ^DIR
49 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
50QUIT K ^TMP("PSD",$J),IO("Q") Q
51HEADER ;prints header info
52 I $E(IOST,1,2)'="P-",PG S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
53 I $$S^%ZTLOAD W !!,"Task #",$G(ZTSK),", ",$G(ZTDESC)," was stopped by ",$P($G(^VA(200,+$G(DUZ),0)),U),"." S PSDOUT=1
54 W:$Y @IOF S $P(LN,"-",80)="",PG=PG+1 W !?2,PSDCHO(1)," From "
55 W $P(PSDATE,U)," To ",$P(PSDATE,U,2),?72,"Page ",PG,!!
56 S PSD(2)=$O(LOC(0)) W "For " W:$G(ALL) "ALL NAOU(s)"
57 W:'$O(LOC(PSD(2)))&('$G(ALL)) $P($G(^PSD(58.8,+$O(LOC(0)),0)),U)
58 I $O(LOC(PSD(2))),'$G(ALL) W "The Following NAOU(s): " D
59 .S PSD(2)=0 F S PSD(2)=$O(LOC(PSD(2))) Q:'PSD(2) W $P($G(^PSD(58.8,+PSD(2),0)),U),!?28
60 W ?45,"Report Date: ",PSDT(1),!!?40,"Quantity",!,"Drug",?40,"Dispensed"
61 W ?70,"Cost",!,LN,!!
Note: See TracBrowser for help on using the repository browser.