source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA1.m@ 1800

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

revised back to 6/30/08 version
File size: 3.1 KB
Line 
1PSOXZA1 ; COMPILED XREF FOR FILE #52 ; 01/17/08
2 ;
3 S DIKZK=2
4 S DIKZ(0)=$G(^PSRX(DA,0))
5 S X=$P(DIKZ(0),U,13)
6 I X'="" K ^PSRX("AC",$E(X,1,30),DA)
7 S X=$P(DIKZ(0),U,2)
8 I X'="" K:$P($G(^PSRX(DA,0)),"^",11)="W"&($P($G(^(2)),"^",2))&('$P($G(^(2)),"^",13))&('$P($G(^(2)),"^",15))&(+$G(^("IB"))) ^PSRX("ACP",X,$P(^PSRX(DA,2),"^",2),0,DA)
9 S X=$P(DIKZ(0),U,2)
10 I X'="" X ^DD(52,2,1,2,2)
11 S X=$P(DIKZ(0),U,2)
12 I X'="" K:$G(PSODEATH) ^PSRX("APSOD",X,DA)
13 S DIKZ(0)=$G(^PSRX(DA,0))
14 S X=$P(DIKZ(0),U,6)
15 I X'="" I X,$P(^PSRX(DA,2),"^",2) K ^PSRX("ADL",$P(^PSRX(DA,2),"^",2),X,DA)
16 S X=$P(DIKZ(0),U,11)
17 I X'="" K:X="W"&($P(^PSRX(DA,0),"^",2))&($P($G(^(2)),"^",2))&('$P($G(^(2)),"^",13))&('$P($G(^(2)),"^",15))&(+$G(^("IB"))) ^PSRX("ACP",$P(^PSRX(DA,0),"^",2),$P(^(2),"^",2),0,DA)
18 S DIKZ(2)=$G(^PSRX(DA,2))
19 S X=$P(DIKZ(2),U,9)
20 I X'="" D KAS^PSOSUTL
21 S X=$P(DIKZ(2),U,2)
22 I X'="" K ^PSRX("AD",X,DA,0)
23 S X=$P(DIKZ(2),U,2)
24 I X'="" K:$P($G(^PSRX(DA,0)),"^",2)&($P($G(^(0)),"^",11)="W")&('$P($G(^(2)),"^",13))&('$P($G(^(2)),"^",15))&('+$G(^("IB"))) ^PSRX("ACP",$P(^PSRX(DA,0),"^",2),X,0,DA)
25 S X=$P(DIKZ(2),U,2)
26 I X'="" D SUSFDK^PSOUTLA
27 S X=$P(DIKZ(2),U,2)
28 I X'="" I X,$P(^PSRX(DA,0),"^",6) K ^PSRX("ADL",X,$P(^PSRX(DA,0),"^",6),DA)
29 S X=$P(DIKZ(2),U,6)
30 I X'="" K ^PSRX("AG",$E(X,1,30),DA)
31 S X=$P(DIKZ(2),U,6)
32 I X'="" K:$P($G(^PSRX(DA,"STA")),"^")'=12 ^PS(55,$P($G(^PSRX(DA,0)),"^",2),"P","A",X,DA)
33 S DIKZ(3)=$G(^PSRX(DA,3))
34 S X=$P(DIKZ(3),U,5)
35 I X'="" S ^PS(55,$P(^PSRX(DA,0),"^",2),"P","A",$P(^PSRX(DA,2),"^",6),DA)="" K ^PS(55,$P(^PSRX(DA,0),"^",2),"P","A",X,DA)
36 S X=$P(DIKZ(2),U,13)
37 I X'="" K ^PSRX("AL",X,DA,0)
38 S X=$P(DIKZ(2),U,13)
39 I X'="" S:$P(^PSRX(DA,0),"^",2)&($P(^(0),"^",11)="W")&($P($G(^(2)),"^",2))&('$P($G(^(2)),"^",15))&(+$G(^("IB"))) ^PSRX("ACP",$P(^PSRX(DA,0),"^",2),$P(^(2),"^",2),0,DA)=""
40 S X=$P(DIKZ(2),U,15)
41 I X'="" K ^PSRX("AJ",X,DA,0)
42 S DIKZ("OR1")=$G(^PSRX(DA,"OR1"))
43 S X=$P(DIKZ("OR1"),U,8)
44 I X'="" K ^PSRX("AFDT",$E(X,1,30),DA)
45 S X=$P(DIKZ("OR1"),U,2)
46 I X'="" K ^PSRX("APL",$E(X,1,30),DA)
47 S X=$P(DIKZ("OR1"),U,3)
48 I X'="" K ^PSRX("AO",$E(X,1,30),DA)
49 S X=$P(DIKZ("OR1"),U,4)
50 I X'="" K ^PSRX("AQ",$E(X,1,30),DA)
51 S DIKZ("H")=$G(^PSRX(DA,"H"))
52 S X=$P(DIKZ("H"),U,1)
53 I X'="" K ^PSRX("AH",$E(X,1,30),DA)
54 S X=$P(DIKZ(3),U,3)
55 I X'="" I $D(^VA(200,+$P(^PSRX(DA,0),"^",4),"PS")),$P(^("PS"),"^",7) S ^PSRX("ANCO",DA)=""
56 S X=$P(DIKZ(0),U,1)
57 I X'="" K ^PSRX("B",$E(X,1,30),DA)
58CR1 S DIXR=175
59 K X
60 S DIKZ("EXT")=$G(^PSRX(DA,"EXT"))
61 S X(1)=$P(DIKZ("EXT"),U,1)
62 S X(2)=$P(DIKZ("EXT"),U,2)
63 S X=$G(X(1))
64 I $G(X(1))]"",$G(X(2))]"" D
65 . K X1,X2 M X1=X,X2=X
66 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
67 . K ^PSRX("D",$E(X(1),1,30),$E(X(2),1,60),DA)
68CR2 S DIXR=250
69 K X
70 S DIKZ(0)=$G(^PSRX(DA,0))
71 S X(1)=$P(DIKZ(0),U,13)
72 S X=$G(X(1))
73 I $G(X(1))]"" D
74 . K X1,X2 M X1=X,X2=X
75 . S:$D(DIKIL) (X2,X2(1))=""
76 . K ^PSRX("APKI",$E(X,1,30),DA)
77CR3 S DIXR=476
78 K X
79 S DIKZ(0)=$G(^PSRX(DA,0))
80 S X(1)=$P(DIKZ(0),U,8)
81 S DIKZ(2)=$G(^PSRX(DA,2))
82 S X(2)=$P(DIKZ(2),U,13)
83 S X=$G(X(1))
84 I $G(X(1))]"",$G(X(2))]"" D
85 . K X1,X2 M X1=X,X2=X
86 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
87 . D SKIDX^PSOPXRMU(.X,.DA,"O","K")
88CR4 K X
89END G ^PSOXZA2
Note: See TracBrowser for help on using the repository browser.