source: WorldVistAEHR/trunk/r/PHARMACY_PRESCRIPTION_PRACTICE-PPP/PPPGET1.m@ 1593

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

initial load of WorldVistAEHR

File size: 4.6 KB
Line 
1PPPGET1 ;ALB/DMB/DAD - PRESC. PRACT. GET ROUTINES ;10-AUG-93
2 ;;1.0;PHARMACY PRESCRIPTION PRACTICE;**8,17,21,39**;APR 7,1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5GETDFN(PATIENT,VERBOSE) ;RETURN DFN OF PATIENT
6 ;THIS WILL RETURN THE SAME INFORMATION THAT DIC RETURNS IN Y
7 ;
8 N DIC,X,Y,DTOUT,DUOUT,RESULT,USRABORT,DGSENFLG
9 ;
10 S DGSENFLG=""
11 S USRABORT=-1001
12 S:'$D(PATIENT) PATIENT=""
13 S:'$D(VERBOSE) VERBOSE=0
14 S VERBOSE=$S(VERBOSE:"E",1:"")
15 ;
16 ;USER INTERFACE
17 S DIC(0)="M"_VERBOSE
18 S:VERBOSE="" DIC(0)=DIC(0)_"X"
19 I PATIENT="" D
20 .S DIC(0)=DIC(0)_"AQ"
21 S X=PATIENT
22 S DIC=2
23 D ^DIC
24 ;
25 ;USER ABORTED PROCESS
26 ;
27 I $D(DTOUT)!($D(DUOUT)) S RESULT=USRABORT
28 E S RESULT=Y
29 ;
30 Q RESULT
31 ;
32GETSNIFN(STATION,VERBOSE) ;RETURN IFN OF INSTITUTION
33 ;THIS WILL RETURN THE SAME INFORMATION THAT DIC RETURNS IN Y
34 ;
35 N DIC,X,Y,DTOUT,DUOUT,RESULT,USRABORT
36 ;
37 S USRABORT=-1001
38 S:'$D(STATION) STATION=""
39 S:'$D(VERBOSE) VERBOSE=0
40 S VERBOSE=$S(VERBOSE:"E",1:"")
41 ;
42 ;USER INTERFACE
43 S DIC(0)="M"_VERBOSE
44 I STATION="" D
45 .S DIC(0)=DIC(0)_"AQ"
46 E D
47 .S DIC(0)=DIC(0)_"X"
48 S X=STATION
49 S DIC=4
50 D ^DIC
51 ;
52 ;USER ABORTED PROCESS
53 ;
54 I $D(DTOUT)!($D(DUOUT)) S RESULT=USRABORT
55 E S RESULT=Y
56 ;
57 Q RESULT
58 ;
59GETFFX(FFXIFN,TARRY) ; Get data from an FFX entry
60 ;
61 N DIC,DR,DA,DIQ,DUOUT,DTOUT,PARMERR,NODE0,NODE1,ARRAYTMP,TMPARRAY,FMERR
62 ;
63 S PARMERR=-9001
64 S FMERR=-9002
65 S TMPARRAY="ARRAYTMP"
66 ;
67 I '$D(FFXIFN) Q PARMERR
68 I '$D(TARRY) Q PARMERR
69 K @TMPARRAY
70 ;
71 ; Get the data from the entry
72 ;
73 S NODE0=$G(^PPP(1020.2,FFXIFN,0)) Q:$P(NODE0,"^")="" PARMERR
74 S NODE1=$G(^PPP(1020.2,FFXIFN,1))
75 ;
76 ; Get the patient name and SSN from the patient file
77 ;
78 S DA=$P(NODE0,"^")
79 I DA'="" D
80 .S DR=".01;.09"
81 .S DIC=2
82 .S DIQ=TMPARRAY
83 .S DIQ(0)="E"
84 .D EN^DIQ1
85 .I '$D(@TMPARRAY) Q FMERR
86 .S @TARRY@(FFXIFN,"NAME")=$G(@TMPARRAY@(2,DA,.01,"E"))
87 .S @TARRY@(FFXIFN,"SSN")=$G(@TMPARRAY@(2,DA,.09,"E"))
88 .K @TMPARRAY
89 E D
90 .S @TARRY@(FFXIFN,"NAME")="NOT AVAILABLE"
91 .S @TARRY@(FFXIFN,"SSN")="NOT AVAILABLE"
92 ;
93 ; Get the institution info from file 4
94 ;
95 S DA=$P(NODE0,"^",2)
96 I DA'="" D
97 .;VMP OIFO BAY PINES;VGF;PPP*1.0*39
98 .S DOMAIN=$$DOMAIN^PPPFMX(FFXIFN)
99 .S LNUM=0 I DOMAIN]"" S LNUM=$O(^PPP(1020.128,"A",DOMAIN,0))
100 .I LNUM S DOMAIN=$P(^PPP(1020.128,LNUM,0),"^",2)
101 .S @TARRY@(FFXIFN,"STANO")=$$GETSTANO(DA)
102 .S @TARRY@(FFXIFN,"POV")=$P(DOMAIN,".",1)
103 .K @TMPARRAY
104 E D
105 .S @TARRY@(FFXIFN,"POV")="NOT AVAILABLE"
106 .S @TARRY@(FFXIFN,"STANO")="NOT AVAILABLE"
107 ;
108 ; Now fill in the rest of the data
109 ;
110 I $P(NODE0,"^",3)'="" D
111 .S @TARRY@(FFXIFN,"LVD")=$$I2EDT^PPPCNV1($P(NODE0,"^",3))
112 E S @TARRY@(FFXIFN,"LVD")="NOT AVAILABLE"
113 I $P(NODE1,"^",2)'="" D
114 .S @TARRY@(FFXIFN,"LPDX")=$$I2EDT^PPPCNV1($P(NODE1,"^",2))
115 E S @TARRY@(FFXIFN,"LPDX")="NOT AVAILABLE"
116 ;VMP OIFO BAY PINES;VGF;PPP*1.0*39
117 I $G(DOMAIN)]"" D
118 .S @TARRY@(FFXIFN,"DOMAIN")=$G(DOMAIN)
119 E S @TARRY@(FFXIFN,"DOMAIN")="NOT AVAILABLE"
120 I $P(NODE1,"^",3)'="" D
121 .S @TARRY@(FFXIFN,"STATUS")=$P($$GETPDXST^PPPGET7($P(NODE1,"^",3)),"^",2)
122 E S @TARRY@(FFXIFN,"STATUS")="NOT AVAILABLE"
123 I $P(NODE1,"^",4)'="" D
124 .S @TARRY@(FFXIFN,"LBRD")=$$I2EDT^PPPCNV1($P(NODE1,"^",4))
125 E S @TARRY@(FFXIFN,"LBRD")="NOT AVAILABLE"
126 I $P(NODE0,"^",4)'="" D
127 .S @TARRY@(FFXIFN,"SOURCE")=$S(($P(NODE0,"^",4)=1):"MANUAL",1:"AUTO")
128 E S @TARRY@(FFXIFN,"SOURCE")="NOT AVAILABLE"
129 I $P(NODE0,"^",5)'="" D
130 .S @TARRY@(FFXIFN,"ED")=$$I2EDT^PPPCNV1($P(NODE0,"^",5))
131 E S @TARRY@(FFXIFN,"ED")="NOT AVAILABLE"
132 Q 0
133 ;
134GETFFIFN(PATDFN,SNIFN) ; Get the FFX ifn for a patient/station entry
135 ;
136 N PARMERR,FINDERR,FFIFN
137 ;
138 S PARMERR=-9001
139 S FINDERR=-9003
140 ;
141 I '$D(PATDFN) K PPPSRT Q PARMERR
142 I '$D(SNIFN) K PPPSRT Q PARMERR
143 ;
144 S FFIFN=$O(^PPP(1020.2,"APOV",PATDFN,SNIFN,""))
145 I FFIFN'>0 Q FINDERR
146 Q FFIFN
147 ;
148GETSSN(DFN) ;
149 ;
150 N DIC,DA,DR,DIQ,PPPTMP,SSN,DUOUT,DTOUT
151 ;
152 S DIC=2,DA=DFN,DR=".09",DIQ="PPPTMP",DIQ(0)="E"
153 D EN^DIQ1
154 S SSN=$G(PPPTMP(2,DFN,.09,"E"))
155 I SSN="" Q -1
156 Q SSN
157 ;
158GETSTANO(SNIFN) ;
159 I $D(^DIC(4,"D",SNIFN)) S STANO=SNIFN Q STANO
160 I $D(^PPP(1020.8,"B",SNIFN)) S STANO=SNIFN Q STANO
161 ;
162 N DIC,DA,DR,DIQ,PPPTMP,STANO
163 ;
164 S DIC=4,DA=SNIFN,DR="99",DIQ="PPPTMP",DIQ(0)="E"
165 ;PPP*1*21
166 D EN^DIQ1
167 S STANO=$G(PPPTMP(4,SNIFN,99,"E"))
168 I STANO="",$D(^PPP(1020.8,"B",SNIFN)) S STANO=SNIFN
169 I STANO="" Q -1
170 Q STANO
171 ;
172GETPATNM(DFN) ;
173 ;
174 N DIC,DA,DR,DIQ,PPPTMP,NAME
175 ;
176 S DIC=2,DA=DFN,DR=".01",DIQ="PPPTMP",DIQ(0)="E"
177 D EN^DIQ1
178 S NAME=$G(PPPTMP(2,DFN,.01,"E"))
179 I NAME="" Q -1
180 Q NAME
181 ;
182GETSTANM(SNIFN) ;
183 ;
184 N NAME
185 ;VMP OIFO BAY PINES;VGF;PPP*1.0*39
186 S SNIFN=$O(^PPP(1020.8,"B",SNIFN,""))
187 I SNIFN="" Q -1
188 S NAME=$P($G(^PPP(1020.8,SNIFN,0)),"^",2),NAME=$P(NAME,".",1)
189 I NAME="" Q -1
190 Q NAME
Note: See TracBrowser for help on using the repository browser.