source: WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDUTL1.m@ 1427

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

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1PSDUTL1 ;BIR/JPW-Utility FM and X-Refs (cont'd) ; 18 Jan 94
2 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
3SACT ;set 'ACT' x-ref on field 3 in 58.81
4 S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDDRU=$P(^(0),"^",5),PSDTYPE=$P(^(0),"^",2)
5 I ('PSDNL)!('PSDDRU)!('PSDTYPE) K PSDNL,PSDDRU,PSDTYPE Q
6 S ^PSD(58.81,"ACT",X,PSDNL,PSDDRU,PSDTYPE,DA)="" K PSDNL,PSDDRU,PSDTYPE
7 Q
8KACT ;kill 'ACT' x-ref on field 3 in 58.81
9 S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDDRU=$P(^(0),"^",5),PSDTYPE=$P(^(0),"^",2)
10 I ('PSDNL)!('PSDDRU)!('PSDTYPE) K PSDNL,PSDDRU,PSDTYPE Q
11 K ^PSD(58.81,"ACT",X,PSDNL,PSDDRU,PSDTYPE,DA),PSDNL,PSDDRU,PSDTYPE
12 Q
13SACT1 ;set 'ACT' x-ref on field 1 in 58.81
14 S PSDATT=$P(^PSD(58.81,DA,0),"^",4),PSDNL=$P(^(0),"^",3),PSDDRU=$P(^(0),"^",5)
15 I ('PSDATT)!('PSDNL)!('PSDDRU) K PSDATT,PSDNL,PSDDRU Q
16 S ^PSD(58.81,"ACT",PSDATT,PSDNL,PSDDRU,X,DA)="" K PSDNL,PSDATT,PSDDRU
17 Q
18KACT1 ;kill 'ACT' x-ref on field 1 in 58.81
19 S PSDATT=$P(^PSD(58.81,DA,0),"^",4),PSDNL=$P(^(0),"^",3),PSDDRU=$P(^(0),"^",5)
20 I ('PSDATT)!('PSDNL)!('PSDDRU) K PSDATT,PSDNL,PSDDRU Q
21 K ^PSD(58.81,"ACT",PSDATT,PSDNL,PSDDRU,X,DA),PSDNL,PSDATT,PSDDRU
22 Q
23SACT2 ;set 'ACT' x-ref on field 2 in 58.81
24 S PSDATT=$P(^PSD(58.81,DA,0),"^",4),PSDDRU=$P(^(0),"^",5),PSDTYPE=$P(^(0),"^",2)
25 I ('PSDATT)!('PSDDRU)!('PSDTYPE) K PSDATT,PSDDRU,PSDTYPE Q
26 S ^PSD(58.81,"ACT",PSDATT,X,PSDDRU,PSDTYPE,DA)="" K PSDATT,PSDDRU,PSDTYPE
27 Q
28KACT2 ;kill 'ACT' x-ref on field 2 in 58.81
29 S PSDATT=$P(^PSD(58.81,DA,0),"^",4),PSDDRU=$P(^(0),"^",5),PSDTYPE=$P(^(0),"^",2)
30 I ('PSDATT)!('PSDDRU)!('PSDTYPE) K PSDATT,PSDDRU,PSDTYPE Q
31 K ^PSD(58.81,"ACT",PSDATT,X,PSDDRU,PSDTYPE,DA),PSDATT,PSDDRU,PSDTYPE
32 Q
33SACT3 ;set 'ACT' x-ref on field 4 in 58.81
34 S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDATT=$P(^(0),"^",4),PSDTYPE=$P(^(0),"^",2)
35 I 'PSDNL!('PSDATT)!('PSDTYPE) K PSDNL,PSDATT,PSDTYPE Q
36 S ^PSD(58.81,"ACT",PSDATT,PSDNL,X,PSDTYPE,DA)="" K PSDATT,PSDNL,PSDTYPE
37 Q
38KACT3 ;kill 'ACT' x-ref on field 4 in 58.81
39 S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDATT=$P(^(0),"^",4),PSDTYPE=$P(^(0),"^",2)
40 I ('PSDNL)!('PSDATT)!('PSDTYPE) K PSDNL,PSDATT,PSDTYPE Q
41 K ^PSD(58.81,"ACT",PSDATT,PSDNL,X,PSDTYPE,DA),PSDNL,PSDATT,PSDTYPE
42 Q
43SACT4 ;set 'ACT' x-ref on field 34 in 58.81
44 S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDDRU=$P(^(0),"^",5),PSDTYPE=3
45 I ('PSDNL)!('PSDDRU)!('PSDTYPE) K PSDNL,PSDDRU,PSDTYPE Q
46 S ^PSD(58.81,"ACT",X,PSDNL,PSDDRU,PSDTYPE,DA)="" K PSDNL,PSDDRU,PSDTYPE
47 Q
48KACT4 ;kill 'ACT' x-ref on field 34 in 58.81
49 S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDDRU=$P(^(0),"^",5),PSDTYPE=3
50 I ('PSDNL)!('PSDDRU)!('PSDTYPE) K PSDNL,PSDDRU,PSDTYPE Q
51 K ^PSD(58.81,"ACT",X,PSDNL,PSDDRU,PSDTYPE,DA),PSDNL,PSDDRU,PSDTYPE
52 Q
53SACT5 ;set 'ACT' x-ref on field 48 in 58.81
54 S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDDRU=$P(^(0),"^",5),PSDTYPE=14
55 I ('PSDNL)!('PSDDRU)!('PSDTYPE) K PSDNL,PSDDRU,PSDTYPE Q
56 S ^PSD(58.81,"ACT",X,PSDNL,PSDDRU,PSDTYPE,DA)="" K PSDNL,PSDDRU,PSDTYPE
57 Q
58KACT5 ;kill 'ACT' x-ref on field 48 in 58.81
59 S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDDRU=$P(^(0),"^",5),PSDTYPE=14
60 I ('PSDNL)!('PSDDRU)!('PSDTYPE) K PSDNL,PSDDRU,PSDTYPE Q
61 K ^PSD(58.81,"ACT",X,PSDNL,PSDDRU,PSDTYPE,DA),PSDNL,PSDDRU,PSDTYPE
62 Q
63SACT6 ;set 'ACT' x-ref on field 55 in 58.81
64 S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDDRU=$P(^(0),"^",5),PSDTYPE=13
65 I ('PSDNL)!('PSDDRU)!('PSDTYPE) K PSDNL,PSDDRU,PSDTYPE Q
66 S ^PSD(58.81,"ACT",X,PSDNL,PSDDRU,PSDTYPE,DA)="" K PSDNL,PSDDRU,PSDTYPE
67 Q
68KACT6 ;kill 'ACT' x-ref on field 55 in 58.81
69 S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDDRU=$P(^(0),"^",5),PSDTYPE=13
70 I ('PSDNL)!('PSDDRU)!('PSDTYPE) K PSDNL,PSDDRU,PSDTYPE Q
71 K ^PSD(58.81,"ACT",X,PSDNL,PSDDRU,PSDTYPE,DA),PSDNL,PSDDRU,PSDTYPE
72 Q
73SAD ;set 'AD' x-ref on field 17 in 58.81
74 S PSDOST=+$P(^PSD(58.81,DA,0),"^",11) I 'PSDOST K PSDOST Q
75 S ^PSD(58.81,"AD",PSDOST,X,DA)="" K PSDOST
76 Q
77KAD ;kill 'AD' x-ref on field 17 in 58.81
78 S PSDOST=+$P(^PSD(58.81,DA,0),"^",11) I 'PSDOST K PSDOST Q
79 K ^PSD(58.81,"AD",PSDOST,X,DA),PSDOST
80 Q
81SAW ;set 'AW' x-ref on field 13 in 58.85
82 S PSDDS=$P(^PSD(58.85,DA,0),"^",2) I 'PSDDS K PSDDS Q
83 S ^PSD(58.85,"AW",PSDDS,X,DA)="" K PSDDS
84 Q
85KAW ;kill 'AW' x-ref on field 13 in 58.85
86 S PSDDS=$P(^PSD(58.85,DA,0),"^",2) I 'PSDDS K PSDDS Q
87 K ^PSD(58.85,"AW",PSDDS,X,DA),PSDDS
88 Q
89SAW1 ;set 'AW' x-ref on field 1 in 58.85
90 Q:'$D(^PSD(58.85,DA,2))
91 S PSDPRT=$P(^PSD(58.85,DA,2),"^") I 'PSDPRT K PSDPRT Q
92 S ^PSD(58.85,"AW",X,PSDPRT,DA)="" K PSDPRT
93 Q
94KAW1 ;kill 'AW' x-ref on field 1 in 58.85
95 Q:'$D(^PSD(58.85,DA,2))
96 S PSDPRT=$P(^PSD(58.85,DA,2),"^") I 'PSDPRT K PSDPRT Q
97 K ^PSD(58.85,"AW",X,PSDPRT,DA),PSDPRT
98 Q
Note: See TracBrowser for help on using the repository browser.