source: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSADAI.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 4.3 KB
Line 
1PSADAI ;BIR/LTL/,JMB/PDW-Drug Balances by Location ;7/23/97
2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15,53**; 10/24/97
3 ;
4 ;Reference to ^PS(59.4 are covered by IA #2505
5 ;References to ^PSDRUG( are covered by IA #2095
6 ;References to ^PRCP( are covered by IA #214
7 ;References to ^PS(59 are covered by IA #212
8 ;
9LOC S (PSACNT,PSAOUT)=0 D ^PSAUTL3 G:PSAOUT EXIT1
10 S PSACNT=0,PSACHK=$O(PSALOC(""))
11 I PSACHK="",'PSALOC W !,"There are no active pharmacy locations." G EXIT1
12 I PSACHK'="",$G(PSASEL)="",PSALOC W !!,PSALOCN
13 ;
14DEVICE W ! K IO("Q") S %ZIS="Q" D ^%ZIS I POP S DTOUT=1,Y=-1 W !,"No Device was selected or output printed." G EXIT1
15 I $D(IO("Q")) S ZTRTN="START^PSADAI",ZTDESC="Drug Accountability - Drug Location Report",ZTSAVE("PSALOC(")="" D ^%ZTLOAD,HOME^%ZIS S Y=1 G EXIT1
16START S PSAOUT=0,PSALOCN="",$P(PSASLN,"-",80)=""
17 S PSARPDT=$E($$HTFM^XLFDT($H),1,12),PSADT=$P(PSARPDT,".")
18 S PSARPDT=$E(PSADT,4,5)_"/"_$E(PSADT,6,7)_"/"_$E(PSADT,2,3)_"@"_$P(PSARPDT,".",2)
19 F S PSALOCN=$O(PSALOC(PSALOCN)) Q:PSALOCN="" D Q:PSAOUT
20 .S PSAIEN=0 F S PSAIEN=+$O(PSALOC(PSALOCN,PSAIEN)) Q:'PSAIEN D Q:PSAOUT
21 ..S PSAISIT=+$P(PSALOC(PSALOCN,PSAIEN),"^"),PSAOSIT=+$P(PSALOC(PSALOCN,PSAIEN),"^",2)
22 ..S PSAISITN=$S($P($G(^PS(59.4,PSAISIT,0)),"^")'="":$P($G(^PS(59.4,PSAISIT,0)),"^"),1:"UNKNOWN")
23 ..S PSAOSITN=$S($P($G(^PS(59,PSAOSIT,0)),"^")'="":$P($G(^PS(59,PSAOSIT,0)),"^"),1:"UNKNOWN")
24 ..S PSASITES=$S(PSAISIT&(PSAOSIT):PSAISITN_" (IP) "_PSAOSITN_" (OP)",PSAISIT:PSAISITN_" (IP)",1:PSAOSITN_" (OP)")
25 ..D COMPILE D:'PSAOUT DONE
26EXIT D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q") W:$E(IOST,1,2)="C-" @IOF
27EXIT1 K ^TMP($J,"PSADRG"),%ZIS,DIR,DIRUT,DTOUT
28 K PSACHK,PSACNT,PSADRG,PSADT,PSAIEN,PSAINV,PSAISIT,PSAISITN,PSALEN,PSALINK,PSALNK,PSALOC,PSALOCA,PSALOCN,PSAOSIT,PSAOSITN
29 K PSAOUT,PSAPG,PSARPDT,PSAS,PSASEL,PSASITES,PSASLN,PSASS,PSATMP,X,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
30 Q
31COMPILE ;Creates ^TMP(Drug Name)= current balance ^ dispense unit ^ total inventory (current balance in 50)
32 K ^TMP($J,"PSADRG")
33 S PSADRG=0 F S PSADRG=+$O(^PSD(58.8,PSAIEN,1,PSADRG)) Q:'PSADRG D
34 .Q:'$D(^PSDRUG(PSADRG,0))
35 .I $P($G(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",4)=0,$P($G(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",14)<DT Q ;*53 0 QT & inactive
36 .S ^TMP($J,"PSADRG",$P(^PSDRUG(PSADRG,0),"^"))=$P($G(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",4)_"^"_$P($G(^PSDRUG(PSADRG,660)),"^",8)_"^"_$P($G(^PSDRUG(PSADRG,660.1)),"^")
37PRINT ;Prints body of report
38 ;Finds longest length of inventory link(s).
39 S (PSALNK,PSALEN)=0 F S PSALNK=+$O(^PSD(58.8,PSAIEN,4,PSALNK)) Q:'PSALNK D
40 .S PSALINK(+$P($G(^PSD(58.8,PSAIEN,4,PSALNK,0)),"^"))=""
41 .S PSAINV="INVENTORY LINK: "_$S($P($G(^PRCP(445,PSALNK,0)),"^")'="":$P($G(^PRCP(445,PSALNK,0)),"^"),1:"NONE")
42 .S:PSALEN<$L(PSAINV) PSALEN=$L(PSAINV)
43 S PSAPG=0,PSADRG="" D HDR
44 ;If no data in ^TMP, prints message & exit routine.
45 S PSATMP=$O(^TMP($J,"PSADRG","")) I PSATMP="" W !!,"<< NO DRUGS WERE FOUND. >>",! G DONE
46 ;If data is found, prints drug name, current balance, & dispense unit
47 F S PSADRG=$O(^TMP($J,"PSADRG",PSADRG)) Q:PSADRG="" D I PSAOUT W:$E(IOST,1,2)="C-" @IOF Q
48 .D:$Y+4>IOSL HDR Q:PSAOUT
49 .W !,PSADRG
50 .S PSALEN=$L($P($P(^TMP($J,"PSADRG",PSADRG),"^"),".",2))
51 .W ?(44+PSALEN),$J($FN($P(^TMP($J,"PSADRG",PSADRG),"^"),",",PSALEN),(10+PSALEN))
52 .W:$P(^TMP($J,"PSADRG",PSADRG),"^",2)'="" ?61,$P(^TMP($J,"PSADRG",PSADRG),"^",2)
53 .W ?69,$J($FN($P(^TMP($J,"PSADRG",PSADRG),"^",3),",",0),9)
54 Q
55DONE ;Holds screen or ejects paper if sent to printer
56 I $E(IOST,1,2)="C-" D
57 .S PSAS=22-$Y F PSASS=1:1:PSAS W !
58 .S DIR(0)="EA",DIR("A")="End of display! Enter RETURN to continue or '^' to exit:" D ^DIR K DIR S:'Y PSAOUT=1
59 W:$E(IOST)'="C" @IOF
60 Q
61HDR ;Print header
62 S PSAPG=PSAPG+1
63 I PSAPG=1,$E(IOST,1,2)="C-" W @IOF
64 I PSAPG>1,$E(IOST)'="C" W @IOF
65 I $E(IOST,1,2)="C-",PSAPG>1 D Q:PSAOUT
66 .S PSAS=22-$Y F PSASS=1:1:PSAS W !
67 .S DIR(0)="E" D ^DIR K DIR W:'$G(DIRUT) @IOF S:'Y PSAOUT=1
68 W:$E(IOST)'="C" !!,PSARPDT W:$E(IOST,1,2)="C-" !
69 W ?21,"D R U G A C C O U N T A B I L I T Y",?71,"Page ",$J(PSAPG,2)
70 W !?24,"DRUG BALANCES BY LOCATION REPORT"
71 W !?((80-$L(PSALOCN))/2),PSALOCN
72 S PSALNK=0 F S PSALNK=$O(PSALINK(PSALNK)) Q:'PSALNK D
73 .S PSAINV="INVENTORY LINK: "_$S($P($G(^PRCP(445,PSALNK,0)),"^")'="":$P($G(^PRCP(445,PSALNK,0)),"^"),1:"NONE")
74 .W !?((80-$L(PSAINV))/2),PSAINV
75 W !!?47,"CURRENT",?58,"DISPENSE",?72,"TOTAL"
76 W !,"DRUG NAME",?47,"BALANCE",?60,"UNIT",?70,"INVENTORY",!,PSASLN
77 Q
Note: See TracBrowser for help on using the repository browser.