source: FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSS50B1.m@ 1607

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1PSS50B1 ;BIR/LDT - API FOR INFORMATION FROM FILE 50; 5 Sep 03
2 ;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
3 ;
4LOOP ;
5 N PSS50DD5,PSS50ER5,PSS501NX D FIELD^DID(50.1,1,"Z","POINTER","PSS50DD5","PSS50ER5") S PSS501NX=$G(PSS50DD5("POINTER"))
6 N PSSENCT
7 S PSSENCT=0
8 S PSS(1)=0 F S PSS(1)=$O(^PSDRUG(PSS(1))) Q:'PSS(1) D
9 .I $P($G(^PSDRUG(PSS(1),0)),"^")="" Q
10 .I $G(PSSFL),$P($G(^PSDRUG(PSS(1),"I")),"^"),$P($G(^("I")),"^")'>PSSFL Q
11 .I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSS(1),2)),"^") Q
12 .;Naked reference below refers to ^PSDRUG(PSS(1),2)
13 .I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^(2)),"^",3)[$E(PSSPK,PSSZ6) S PSSZ5=1
14 .I $G(PSSPK)]"",'PSSZ5 Q
15 .D SETSUB1^PSS50AQM(PSS(1)),SETSUB4^PSS50AQM(PSS(1))
16 .D SETINV,SETSYN2,SETIFC
17 .S PSSENCT=PSSENCT+1
18 S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
19 Q
20SETINV ;
21 N PSSZNODE,PSS660,PSS6601
22 S PSSZNODE=$G(^PSDRUG(PSS(1),0)),PSS660=$G(^(660)),PSS6601=$G(^(660.1))
23 S ^TMP($J,LIST,+PSS(1),.01)=$P(PSSZNODE,"^")
24 S ^TMP($J,LIST,"B",$P(PSSZNODE,"^"),+PSS(1))=""
25 S ^TMP($J,LIST,+PSS(1),11)=$P(PSS660,"^")
26 S ^TMP($J,LIST,+PSS(1),12)=$S($P(PSS660,"^",2):$P(PSS660,"^",2)_"^"_$P($G(^DIC(51.5,+$P(PSS660,"^",2),0)),"^")_"^"_$P($G(^(0)),"^",2),1:"")
27 S ^TMP($J,LIST,+PSS(1),13)=$P(PSS660,"^",3)
28 S ^TMP($J,LIST,+PSS(1),14)=$P(PSS660,"^",4)
29 S ^TMP($J,LIST,+PSS(1),15)=$P(PSS660,"^",5)
30 S ^TMP($J,LIST,+PSS(1),16)=$P(PSS660,"^",6)
31 S ^TMP($J,LIST,+PSS(1),17)=$P(PSS660,"^",7)
32 S ^TMP($J,LIST,+PSS(1),14.5)=$P(PSS660,"^",8)
33 N Y S Y=$P(PSS660,"^",9) D
34 .I Y S ^TMP($J,LIST,+PSS(1),17.1)=$G(Y) X ^DD("DD") S ^TMP($J,LIST,+PSS(1),17.1)=^TMP($J,LIST,+PSS(1),17.1)_"^"_$G(Y) Q
35 .S ^TMP($J,LIST,+PSS(1),17.1)=""
36 S ^TMP($J,LIST,+PSS(1),50)=$P(PSS6601,"^")
37 Q
38SETSYN2 ;
39 N PSS501C S PSS501C=0
40 I $O(^PSDRUG(PSS(1),1,0)) N PSS501,PSS501ND D
41 .F PSS501=0:0 S PSS501=$O(^PSDRUG(PSS(1),1,PSS501)) Q:'PSS501 D
42 ..S PSS501ND=$G(^PSDRUG(PSS(1),1,PSS501,0)) I $P(PSS501ND,"^")'="" S PSS501C=PSS501C+1 D
43 ...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,.01)=$P(PSS501ND,"^")
44 ...N PSS501NN S PSS501NN=$P(PSS501ND,"^",3) D
45 ....I PSS501NN'="",PSS501NX'="",PSS501NX[(PSS501NN_":") S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,1)=PSS501NN_"^"_$P($E(PSS501NX,$F(PSS501NX,(PSS501NN_":")),999),";") Q
46 ....S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,1)=""
47 ...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,2)=$P(PSS501ND,"^",2)
48 ...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,400)=$P(PSS501ND,"^",4)
49 ...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,401)=$S($P(PSS501ND,"^",5):$P(PSS501ND,"^",5)_"^"_$P($G(^DIC(51.5,+$P(PSS501ND,"^",5),0)),"^")_"^"_$P($G(^(0)),"^",2),1:"")
50 ...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,402)=$P(PSS501ND,"^",6)
51 ...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,403)=$P(PSS501ND,"^",7)
52 ...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,404)=$P(PSS501ND,"^",8)
53 ...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,405)=$P(PSS501ND,"^",9)
54 S ^TMP($J,LIST,+PSS(1),"SYN",0)=$S(PSS501C:PSS501C,1:"-1^NO DATA FOUND")
55 Q
56SETIFC ;
57 N PSS441C S PSS441C=0
58 I $O(^PSDRUG(PSS(1),441,0)) N PSS441,PSS441ND D
59 .F PSS441=0:0 S PSS441=$O(^PSDRUG(PSS(1),441,PSS441)) Q:'PSS441 D
60 ..S PSS441ND=$G(^PSDRUG(PSS(1),441,PSS441,0)) I $P(PSS441ND,"^")'="" S PSS441C=PSS441C+1 D
61 ...S ^TMP($J,LIST,+PSS(1),"IFC",PSS441,.01)=$P(PSS441ND,"^")
62 S ^TMP($J,LIST,+PSS(1),"IFC",0)=$S(PSS441C:PSS441C,1:"-1^NO DATA FOUND")
63 Q
64 ;
65AVSN ;
66 ;PSSVAL - ITEM NUMBER sub-field (#.01) of the IFCAP ITEM NUMBER multiple of the DRUG file (#50)
67 ;PSSFL - Inactive flag - "" - All entries
68 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
69 ;PSSPK - Application Package's Use - "" - All entries
70 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
71 ; part of their formulary.
72 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
73 ; piece being returned.
74 ;Returns zero node of 50
75 I $G(LIST)']"" Q
76 K ^TMP($J,LIST)
77 I +$G(PSSVAL)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
78 N PSS,CNT,PSSIEN S (CNT,PSS)=0 F S PSS=$O(^PSDRUG("AVSN",+PSSVAL,PSS)) Q:'PSS D
79 .N INODE,NODE2 S NODE2=$G(^PSDRUG(+PSS,2)),INODE=$G(^("I"))
80 .I +$G(PSSFL)>0,+INODE>0,+INODE'>PSSFL Q
81 .;Naked reference below refers to ^PSDRUG(+Y,2)
82 .I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^(2)),"^",3)[$E(PSSPK,PSSZ6) S PSSZ5=1
83 .I $G(PSSPK)]"",'PSSZ5 Q
84 .K ^TMP($J,"PSS50") D GETS^DIQ(50,+PSS,".01;9*","IE","^TMP($J,""PSS50""") D
85 ..S PSS(1)=0 F S PSS(1)=$O(^TMP($J,"PSS50",50,PSS(1))) Q:'PSS(1) D
86 ...S ^TMP($J,LIST,+PSS(1),.01)=$G(^TMP($J,"PSS50",50,PSS(1),.01,"I")),CNT=CNT+1
87 ...S ^TMP($J,LIST,"AVSN",$G(^TMP($J,"PSS50",50,PSS(1),.01,"I")),+PSS(1))="",PSSIEN=+PSS(1)
88 ..S (CNT(1),PSS(2))=0 F S PSS(2)=$O(^TMP($J,"PSS50",50.1,PSS(2))) Q:'PSS(2) D
89 ...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),.01)=$G(^TMP($J,"PSS50",50.1,PSS(2),.01,"I")),CNT(1)=CNT(1)+1
90 ...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),2)=$G(^TMP($J,"PSS50",50.1,PSS(2),2,"I"))
91 ...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),1)=$S($G(^TMP($J,"PSS50",50.1,PSS(2),1,"I"))="":"",1:$G(^TMP($J,"PSS50",50.1,PSS(2),1,"I"))_"^"_$G(^TMP($J,"PSS50",50.1,PSS(2),1,"E")))
92 ...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),400)=$G(^TMP($J,"PSS50",50.1,PSS(2),400,"I"))
93 ...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),401)=$S($G(^TMP($J,"PSS50",50.1,PSS(2),401,"I"))="":"",1:$G(^TMP($J,"PSS50",50.1,PSS(2),401,"I"))_"^"_$G(^TMP($J,"PSS50",50.1,PSS(2),401,"E")))
94 ...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),402)=$G(^TMP($J,"PSS50",50.1,PSS(2),402,"I"))
95 ...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),403)=$G(^TMP($J,"PSS50",50.1,PSS(2),403,"I"))
96 ...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),404)=$G(^TMP($J,"PSS50",50.1,PSS(2),404,"I"))
97 ...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),405)=$G(^TMP($J,"PSS50",50.1,PSS(2),405,"I"))
98 ..S ^TMP($J,LIST,+PSSIEN,"SYN",0)=$S(CNT(1)>0:CNT(1),1:"-1^NO DATA FOUND")
99 S ^TMP($J,LIST,0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
100 K ^TMP($J,"PSS50")
101 Q
102 ;
103AQ1 ;
104 ;PSSVAL - ITEM NUMBER sub-field (#.01) of the IFCAP ITEM NUMBER multiple of the DRUG file (#50)
105 ;PSSFL - Inactive flag - "" - All entries
106 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
107 ;PSSPK - Application Package's Use - "" - All entries
108 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
109 ; part of their formulary.
110 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
111 ; piece being returned.
112 ;Returns zero node of 50
113 I $G(LIST)']"" Q
114 K ^TMP($J,LIST)
115 I $G(PSSVAL)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
116 N PSS,CNT S (CNT,PSS)=0 F S PSS=$O(^PSDRUG("AQ1",PSSVAL,PSS)) Q:'PSS D
117 .N INODE,NODE2,ZNODE S NODE2=$G(^PSDRUG(+PSS,2)),INODE=$G(^("I")),ZNODE=$G(^(0))
118 .I +$G(PSSFL)>0,+INODE>0,+INODE'>PSSFL Q
119 .;Naked reference below refers to ^PSDRUG(+PSS,2)
120 .I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^(2)),"^",3)[$E(PSSPK,PSSZ6) S PSSZ5=1
121 .I $G(PSSPK)]"",'PSSZ5 Q
122 .S ^TMP($J,LIST,+PSS,.01)=$P(ZNODE,"^"),CNT=CNT+1
123 .S ^TMP($J,LIST,"AQ1",$P(ZNODE,"^"),+PSS)=""
124 S ^TMP($J,LIST,0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
125 Q
126 ;
127AIU ;
128 ;PSSFT - NAME field (#.01) of the DRUG file (#50)
129 ;PSSPK - Application Package's Use - "" - All entries
130 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
131 ; part of their formulary.
132 ;PSSFL - Inactive flag - "" - All entries
133 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
134 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
135 ; piece being returned.
136 ;Returns NAME field (#.01) of DRUG file (#50).
137 I $G(LIST)']"" Q
138 K ^TMP($J,LIST)
139 I $G(PSSFT)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
140 I $G(PSSPK)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
141 N PSS,CNT S CNT=0,PSS="" F S PSS=$O(^PSDRUG("AIU"_PSSPK,PSS)) Q:PSS="" S PSS(1)=0 F S PSS(1)=$O(^PSDRUG("AIU"_PSSPK,PSS,PSS(1))) Q:'PSS(1) D
142 .N INODE,NODE2,ZNODE S NODE2=$G(^PSDRUG(+PSS(1),2)),INODE=$G(^("I")),ZNODE=$G(^(0))
143 .I +$G(PSSFL)>0,+INODE>0,+INODE'>PSSFL Q
144 .I $E(PSS,1,$L(PSSFT))'[PSSFT Q
145 .S ^TMP($J,LIST,+PSS(1),.01)=$P(ZNODE,"^"),CNT=CNT+1
146 .S ^TMP($J,LIST,"AIU",$P(ZNODE,"^"),+PSS(1))=""
147 S ^TMP($J,LIST,0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
148 Q
149 ;
150IU ;
151 ;PSSFL - Inactive flag - "" - All entries
152 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
153 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
154 ; piece being returned.
155 ;Returns NAME field (#.01) of DRUG file (#50).
156 I $G(LIST)']"" Q
157 K ^TMP($J,LIST)
158 N PSS,CNT
159 S CNT=0,PSS="" F S PSS=$O(^PSDRUG("IU",PSS)) Q:PSS="" I PSS'["O"&(PSS'["U")&(PSS'["I")&(PSS'["N") S PSS(1)=0 F S PSS(1)=$O(^PSDRUG("IU",PSS,PSS(1))) Q:'PSS(1) D
160 .N INODE,ZNODE S ZNODE=$G(^PSDRUG(+PSS(1),0)),INODE=$G(^("I"))
161 .I +$G(PSSFL)>0,+INODE>0,+INODE'>PSSFL Q
162 .S ^TMP($J,LIST,+PSS(1),.01)=$P(ZNODE,"^"),CNT=CNT+1
163 .S ^TMP($J,LIST,"IU",$P(ZNODE,"^"),+PSS(1))=""
164 S ^TMP($J,LIST,0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
165 Q
Note: See TracBrowser for help on using the repository browser.