source: WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSS50F1.m@ 771

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

initial load of WorldVistAEHR
File size: 9.2 KB
Line 
1PSS50F1 ;BIR/RTR - API FOR INFORMATION FROM FILE 50
2 ;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
3 ;
4 ;Reference to ^PS(50.605 is supported by DBIA #2138
5 ;
6LIST ;
7 ;PSSFT - Free Text name in 50
8 ;PSSFL - Inactive flag - "" - All entries
9 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
10 ;PSSD - Index used in the lookup in the format B^C
11 ;PSSPK - Application Package's Use - "" - All entries
12 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
13 ; part of their formulary.
14 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
15 ; piece being returned.
16 N DIERR,ZZERR,PSSP50,SCR,PSS,CNT,PSSXSUB,PSSLUPAR,PSSLUPP,PSSSCRN,PSSENCT
17 I $G(LIST)']"" Q
18 K ^TMP($J,LIST)
19 I $G(PSSFT)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
20 S SCR("S")=""
21 S PSSXSUB="" D SETXSUB
22 S PSSENCT=0
23 I +$G(PSSFL)>0!($G(PSSPK)]"") N PSS5ND,PSSZ3,PSSZ4 D SETSCRN^PSS50A
24 I $G(PSSFT)]"" D
25 .I PSSFT["??" D LOOP Q
26 .K ^TMP("DILIST",$J),^TMP($J,"PSSLDONE")
27 .S PSSSCRN=$G(SCR("S")) S:$G(PSSD)="" PSSD="B" D PARSE^PSS50F(PSSD) I '$O(PSSLUPAR(0)) Q
28 .S PSSLUPP=0 F S PSSLUPP=$O(PSSLUPAR(PSSLUPP)) Q:'PSSLUPP D
29 ..S SCR("S")=$G(PSSSCRN)
30 ..D FIND^DIC(50,,"@;.01","QPB"_$S($P(PSSLUPAR(PSSLUPP),"^",2):"X",1:""),PSSFT,,PSSLUPAR(PSSLUPP),SCR("S"),,"")
31 ..I +$G(^TMP("DILIST",$J,0))=0 Q
32 ..I +^TMP("DILIST",$J,0)>0 N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D
33 ...S PSSIEN=+^TMP("DILIST",$J,PSSXX,0) I '$D(^TMP($J,"PSSLDONE",PSSIEN)) S ^TMP($J,"PSSLDONE",PSSIEN)="" D
34 ....K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN,".01;100;2.1","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
35 ....F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETLIST
36 S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
37 K ^TMP("DILIST",$J),^TMP("PSSP50",$J),^TMP($J,"PSSLDONE")
38 Q
39SETLIST ;
40 S PSSENCT=PSSENCT+1
41 S ^TMP($J,LIST,+PSS(1),.01)=$G(^TMP("PSSP50",$J,50,PSS(1),.01,"I"))
42 ;S ^TMP($J,LIST,"B",$G(^TMP("PSSP50",$J,50,PSS(1),.01,"I")),+PSS(1))=""
43 ;S ^TMP($J,LIST,$S($G(PSSD)]"":$P(PSSD,"^"),1:"B"),^TMP("PSSP50",$J,50,PSS(1),.01,"I"),+PSS(1))=""
44 S ^TMP($J,LIST,$S($G(PSSXSUB)'="":$G(PSSXSUB),1:"B"),^TMP("PSSP50",$J,50,PSS(1),.01,"I"),+PSS(1))=""
45 S ^TMP($J,LIST,+PSS(1),2.1)=$S($G(^TMP("PSSP50",$J,50,PSS(1),2.1,"I"))="":"",1:$G(^TMP("PSSP50",$J,50,PSS(1),2.1,"I"))_"^"_$G(^TMP("PSSP50",$J,50,PSS(1),2.1,"E")))
46 I $P($G(^TMP($J,LIST,+PSS(1),2.1)),"^") D
47 .N PSSADDF S PSSADDF=$$SETDF^PSS50AQM($P(^TMP($J,LIST,+PSS(1),2.1),"^")) S ^TMP($J,LIST,+PSS(1),2.1)=^TMP($J,LIST,+PSS(1),2.1)_$S($P($G(PSSADDF),"^")>0:"^"_$P($G(PSSADDF),"^",3)_"^"_$P($G(PSSADDF),"^",4),1:"")
48 S ^TMP($J,LIST,+PSS(1),100)=$S($G(^TMP("PSSP50",$J,50,PSS(1),100,"I"))="":"",1:$G(^TMP("PSSP50",$J,50,PSS(1),100,"I"))_"^"_$G(^TMP("PSSP50",$J,50,PSS(1),100,"E")))
49 Q
50LOOP ;
51 S PSS(1)=0 F S PSS(1)=$O(^PSDRUG(PSS(1))) Q:'PSS(1) D
52 .I $P($G(^PSDRUG(PSS(1),0)),"^")="" Q
53 .I $G(PSSFL),$P($G(^PSDRUG(PSS(1),"I")),"^"),$P($G(^("I")),"^")'>PSSFL Q
54 .;I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSS(1),2)),"^") Q
55 .;Naked reference below refers to ^PSDRUG(PSS(1),2)
56 .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
57 .I $G(PSSPK)]"",'PSSZ5 Q
58 .D SETLISTL
59 .S PSSENCT=PSSENCT+1
60 Q
61SETLISTL ;
62 N PSSZNODE,PSS2NODE S PSSZNODE=$G(^PSDRUG(PSS(1),0)),PSS2NODE=$G(^(2))
63 S ^TMP($J,LIST,+PSS(1),.01)=$P(PSSZNODE,"^")
64 S ^TMP($J,LIST,"B",$P(PSSZNODE,"^"),+PSS(1))=""
65 S ^TMP($J,LIST,+PSS(1),2.1)=$S('$P(PSS2NODE,"^"):"",1:$P(PSS2NODE,"^")_"^"_$P($G(^PS(50.7,+$P(PSS2NODE,"^"),0)),"^"))
66 N PSSADDF S PSSADDF=$P($G(^PS(50.7,+$P($G(^TMP($J,LIST,+PSS(1),2.1)),"^"),0)),"^",2) I PSSADDF>0 D
67 .S ^TMP($J,LIST,+PSS(1),2.1)=^TMP($J,LIST,+PSS(1),2.1)_"^"_PSSADDF_"^"_$P($G(^PS(50.606,PSSADDF,0)),"^")
68 N Y S Y=$P($G(^PSDRUG(PSS(1),"I")),"^") D
69 .I Y S ^TMP($J,LIST,+PSS(1),100)=$G(Y) X ^DD("DD") S ^TMP($J,LIST,+PSS(1),100)=^TMP($J,LIST,+PSS(1),100)_"^"_$G(Y) Q
70 .S ^TMP($J,LIST,+PSS(1),100)=""
71 Q
72SETXSUB ;
73 Q:$G(PSSD)=""
74 N PSSLSX,PSSLSXCT,PSSLCNT,PSSDSUB
75 S PSSLSXCT=0
76 F PSSLSX=1:1:$L(PSSD) I $E(PSSD,PSSLSX)="^" S PSSLSXCT=PSSLSXCT+1
77 S PSSLSXCT=PSSLSXCT+1
78 S PSSLCNT=0 F PSSLSX=1:1:PSSLSXCT S PSSDSUB=$P(PSSD,"^",PSSLSX) Q:PSSLCNT>1 S PSSXSUB=$S(PSSDSUB'="":PSSDSUB,PSSXSUB'="":PSSXSUB,1:"") S:PSSDSUB'="" PSSLCNT=PSSLCNT+1
79 I PSSLCNT>1 S PSSXSUB=""
80 Q
81LOOKUP ;
82 ;PSSFT - Free Text value that could be the NAME field (#.01), IEN, VA PRODUCT NAME field (#21), NATIONAL DRUG CLASS field (#25),
83 ; or SYNONYM (#.01) mutiple of the DRUG file (#50).
84 ;PSSFL - Inactive flag - "" - All entries
85 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
86 ;PSSPK - Application Package's Use - "" - All entries
87 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
88 ; part of their formulary.
89 ;PSSRTOI - 1 - only drugs with data in the PHARMACY ORDERABLE ITEM field (#2.1) will be returned.
90 ;PSSIFCAP - 1 - only drugs with no data in the IFCAP ITEM NUMBER multiple (#441) will be returned.
91 ;PSSCMOP - 1 - only drugs with no data in the CMOP ID field (#27) will be returned.
92 ;PSSD - Index used in the lookup in the format B^C.
93 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
94 ; piece being returned.
95 N PSSLKIEN,PSSLKSUB,PSSENCT,SCR,PSSXSUB,CNT,PSS,DIERR
96 I $G(LIST)']"" Q
97 K ^TMP($J,LIST)
98 I $G(PSSFT)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
99 S PSSENCT=0
100 I PSSFT["??" D LOOPLK Q
101 S SCR("S")=""
102 I $G(PSSCMOP)=1 D
103 .S SCR("S")="I $P($G(^(""ND"")),""^"",10)=""""" Q
104 I $G(PSSIFCAP)=1 D
105 .I SCR("S")="" S SCR("S")="I '$O(^PSDRUG(+Y,441,0))" Q
106 .S SCR("S")=SCR("S")_" I '$O(^PSDRUG(+Y,441,0))"
107 I +$G(PSSFL)>0!($G(PSSPK)]"")!($G(PSSRTOI)=1) N PSS5ND,PSSZ3,PSSZ4 D SETSCRN
108 I PSSFT'="",PSSFT?1"`"1N.N D S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND") Q
109 .N PSSIEN2 S PSSIEN2=$$FIND1^DIC(50,"","A",PSSFT,,SCR("S"),"")
110 .K ^TMP("DIERR",$J)
111 .I +PSSIEN2'>0 Q
112 .I $P($G(^PSDRUG(+PSSIEN2,0)),"^")="" Q
113 .S PSSLKIEN=+PSSIEN2,PSSLKSUB="B"
114 .D LOOKSET
115 I $G(PSSFT)]"" D
116 .N PSSLUPAR,PSSLUPP,PSSSCRN
117 .S PSSXSUB="" D SETXSUB S PSSLKSUB=$S($G(PSSXSUB)'="":$G(PSSXSUB),1:"B")
118 .K ^TMP("DILIST",$J),^TMP($J,"PSSLDONE")
119 .S PSSSCRN=$G(SCR("S")) S:$G(PSSD)="" PSSD="B" D PARSE^PSS50F(PSSD) I '$O(PSSLUPAR(0)) Q
120 .S PSSLUPP=0 F S PSSLUPP=$O(PSSLUPAR(PSSLUPP)) Q:'PSSLUPP D
121 ..S SCR("S")=PSSSCRN
122 ..D FIND^DIC(50,,"@;.01","QPB"_$S($P(PSSLUPAR(PSSLUPP),"^",2):"X",1:""),PSSFT,,PSSLUPAR(PSSLUPP),SCR("S"),,"")
123 ..I +$G(^TMP("DILIST",$J,0))=0 Q
124 ..I +^TMP("DILIST",$J,0)>0 N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D
125 ...S PSSLKIEN=+^TMP("DILIST",$J,PSSXX,0) I $P($G(^PSDRUG(PSSLKIEN,0)),"^")'="",'$D(^TMP($J,"PSSLDONE",PSSLKIEN)) S ^TMP($J,"PSSLDONE",PSSLKIEN)="" D LOOKSET
126 S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
127 K ^TMP("DILIST",$J),^TMP($J,"PSSLDONE")
128 Q
129LOOKSET ;
130 ;PSSLKIEN = ien from File 50
131 ;PSSLKSUB = Subscript for the cross reference return
132 N PSSLKNAM,PSSLKND,PSSLKZER
133 S PSSLKNAM=$P($G(^PSDRUG(PSSLKIEN,0)),"^"),PSSLKND=$G(^("ND")),PSSLKZER=$G(^(0)) Q:PSSLKNAM=""
134 S ^TMP($J,LIST,PSSLKIEN,.01)=PSSLKNAM
135 S ^TMP($J,LIST,PSSLKSUB,PSSLKNAM,PSSLKIEN)=""
136 S PSSENCT=PSSENCT+1
137 S ^TMP($J,LIST,PSSLKIEN,25)=$S($P(PSSLKND,"^",6):$P(PSSLKND,"^",6)_"^"_$P($G(^PS(50.605,+$P(PSSLKND,"^",6),0)),"^")_"^"_$P($G(^(0)),"^",2),1:"")
138 N Y S Y=$P($G(^PSDRUG(PSSLKIEN,"I")),"^") D
139 .I Y S ^TMP($J,LIST,PSSLKIEN,100)=$G(Y) X ^DD("DD") S ^TMP($J,LIST,PSSLKIEN,100)=^TMP($J,LIST,PSSLKIEN,100)_"^"_$G(Y) Q
140 .S ^TMP($J,LIST,PSSLKIEN,100)=""
141 S ^TMP($J,LIST,PSSLKIEN,101)=$P(PSSLKZER,"^",10)
142 Q
143LOOPLK ;
144 S PSSLKSUB="B"
145 S PSSLKIEN=0 F S PSSLKIEN=$O(^PSDRUG(PSSLKIEN)) Q:'PSSLKIEN D
146 .I $P($G(^PSDRUG(PSSLKIEN,0)),"^")="" Q
147 .I $G(PSSCMOP)=1,$P($G(^PSDRUG(PSSLKIEN,"ND")),"^",10)'="" Q
148 .I $G(PSSIFCAP)=1,$O(^PSDRUG(PSSLKIEN,441,0)) Q
149 .I $G(PSSFL),$P($G(^PSDRUG(PSSLKIEN,"I")),"^"),$P($G(^("I")),"^")'>PSSFL Q
150 .I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSSLKIEN,2)),"^") Q
151 .I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^PSDRUG(PSSLKIEN,2)),"^",3)[$E(PSSPK,PSSZ6) S PSSZ5=1
152 .I $G(PSSPK)]"",'PSSZ5 Q
153 .D LOOKSET
154 S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
155 Q
156 ;
157SETSCRN ;Set Screen
158 I +$G(PSSFL)>0 D
159 .I SCR("S")]"" S SCR("S")=SCR("S")_" S PSS5ND=$P($G(^PSDRUG(+Y,""I"")),""^"") I PSS5ND=""""!(PSS5ND>PSSFL)" Q
160 .S SCR("S")="S PSS5ND=$P($G(^PSDRUG(+Y,""I"")),""^"") I PSS5ND=""""!(PSS5ND>PSSFL)"
161 I $G(PSSRTOI)=1 D
162 .I SCR("S")]"" S SCR("S")=SCR("S")_" I $P($G(^PSDRUG(+Y,2)),""^"")" Q
163 .S SCR("S")="I $P($G(^PSDRUG(+Y,2)),""^"")"
164 I $G(PSSPK)]"" D
165 .I SCR("S")]"" S SCR("S")=SCR("S")_" S PSSZ3=0 F PSSZ4=1:1:$L(PSSPK) Q:PSSZ3 I $P($G(^PSDRUG(+Y,2)),""^"",3)[$E(PSSPK,PSSZ4) S PSSZ3=1" Q
166 .S SCR("S")="S PSSZ3=0 F PSSZ4=1:1:$L(PSSPK) Q:PSSZ3 I $P($G(^PSDRUG(+Y,2)),""^"",3)[$E(PSSPK,PSSZ4) S PSSZ3=1"
167 ;I $G(PSSPK)]"" S SCR("S")=$S(SCR("S")]"":SCR("S")_" I $G(^PSDRUG(+Y,2)),$P($G(^PSDRUG(+Y,2)),""^"",3)[PSSPK",1:"I $G(^PSDRUG(+Y,2)),$P($G(^PSDRUG(+Y,2)),""^"",3)[PSSPK")
168 Q
Note: See TracBrowser for help on using the repository browser.