source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m@ 1008

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

initial load of FOIAVistA 6/30/08 version

File size: 7.5 KB
Line 
1ALPBUTL1 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03
2 ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ; Reference/IA
6 ; INP^VADPT/10061
7 ; DIC(42/10039
8 ; DIC(42/2440
9 ;
10ERRBLD(SEG,MSG,ERR) ; build an error array for non-FileMan-related errors...
11 ; SEG = HL7 segment name
12 ; MSG = a message that will be used in the error text portion of the array (optional -- if not passed, the
13 ; default will be used)
14 ; ERR = array passed by reference in which error will be returned
15 ; note: code 999 is a code indicating a non-FileMan error for filing the error message in file 53.71
16 S ERR("DIERR")=1
17 S ERR("DIERR",1)=999
18 S ERR("DIERR",1,"TEXT",1)=$S($G(MSG)'="":MSG,1:"Invalid parameter passed to "_SEG_" module in routine ALPBHL1U")
19 Q
20 ;
21ERRLOG(IEN,OIEN,MSGREC,SEGNAME,SEGDATA,ERRTEXT) ; log filing errors...
22 ; this module logs error data in the BCMA BACKUP PARAMETERS file (53.71). These
23 ; errors usually occur as the result of missing or bad data passed to one of the
24 ; File Manager DBS calls used by this package.
25 ;
26 ; IEN = the patient's record number in file 53.7
27 ; OIEN = the order number's sub-file record number in file 53.7
28 ; MSGREC = the HL7 message's record number in file 772
29 ; SEGNAME = the HL7 segment associated with the error (optional)
30 ; SEGDATA = the HL7 segment's data (optional)
31 ; ERRTEXT = an array passed by reference which contains the error
32 ; code (numeric) and the error text to be filed. It is
33 ; expected that this is usually the error array returned
34 ; from a FileMan DBS call, so the format is specific:
35 ;
36 ; ERRTEXT("DIERR",n)=error code (numeric)
37 ; ERRTEXT("DIERR",n,"TEXT",1)=first line of error text
38 ; ERRTEXT("DIERR",n,"TEXT",2)=second line of error text
39 ; ERRTEXT("DIERR",n,"TEXT",n)=last line of error text
40 ;
41 ; However, any error message can be passed to this module
42 ; as long as the above format is used.
43 N ALPBCODE,ALPBFERR,ALPBFILE,ALPBLOGD,ALPBN1,ALPBN2,ALPBPIEN,ALPBTEXT,ALPBX
44 S ALPBLOGD=$$NOW^XLFDT()
45 S ALPBPIEN=+$O(^ALPB(53.71,0))
46 I ALPBPIEN=0 D
47 .S X="ONE"
48 .S DIC="^ALPB(53.71,"
49 .S DIC(0)="LZ"
50 .S DIC("DR")="1///^S X=3"
51 .S DINUM=1
52 .S DLAYGO=53.71
53 .D FILE^DICN K DIC
54 .S ALPBPIEN=+Y
55 I ALPBPIEN'>0 Q
56 S ALPBN1=+$O(^ALPB(53.71,ALPBPIEN,1," "),-1)+1
57 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",.01)=ALPBLOGD
58 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",1)=+$G(IEN)
59 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",2)=+$G(OIEN)
60 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3)=+$G(MSGREC)
61 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.1)=$G(SEGNAME)
62 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.2)=$G(SEGDATA)
63 D UPDATE^DIE("","ALPBFILE","ALPBN1","ALPBFERR")
64 K ALPBFERR,ALPBFILE
65 S ALPBX=0
66 F S ALPBX=$O(ERRTEXT("DIERR",ALPBX)) Q:'ALPBX D
67 .S ALPBCODE=ERRTEXT("DIERR",ALPBX)
68 .; file the error code...
69 .S ALPBN2=+$O(^ALPB(53.71,ALPBPIEN,1,ALPBN1,2," "),-1)+1
70 .S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",.01)=ALPBCODE
71 .D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
72 .K ALPBFERR,ALPBFILE
73 .; file the error text...
74 .M ALPBTEXT=ERRTEXT("DIERR",ALPBX,"TEXT")
75 .D WP^DIE(53.7135,ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1,"","ALPBTEXT","ALPBFERR")
76 .;S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1)=ALPBTEXT
77 .;D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
78 .K ALPBCODE,ALPBFERR,ALPBFILE,ALPBN2,ALPBTEXT
79 Q
80 ;
81CLEAN(IEN) ; check error log records to see if the patients' whose records
82 ; are noted still exist in file 53.7. if not, delete the error log
83 ; record(s) in file 53.71...
84 ; IEN = patient record number in file 53.7
85 ; Note: this function is also called from DELPT^ALPBUTL when a patient's
86 ; record is deleted (as a result of a discharge action) from 53.7.
87 ;
88 N ALPBX,ALPBY,DA,DIK,X,Y
89 ; patient still has record in 53.7? if so, quit...
90 I $G(^ALPB(53.7,IEN,0))'="" Q
91 S ALPBX=0
92 F S ALPBX=$O(^ALPB(53.71,"C",IEN,ALPBX)) Q:'ALPBX D
93 .S ALPBY=0
94 .F S ALPBY=$O(^ALPB(53.71,"C",IEN,ALPBX,ALPBY)) Q:'ALPBY D
95 ..S DA=ALPBY
96 ..S DA(1)=ALPBX
97 ..S DIK="^ALPB(53.71,"_DA(1)_",1,"
98 ..D ^DIK
99 ..K DA,DIK
100 .K ALPBY
101 K ALPBX
102 Q
103 ;
104DELERR(ERRIEN) ; delete an error log entry from file 53.71...
105 ; ERRIEN = error log entry's internal record number
106 N ALPBPARM,DA,DIK,X,Y
107 S ALPBPARM=+$O(^ALPB(53.71,0))
108 I ALPBPARM'>0 Q
109 S DA=ERRIEN
110 S DA(1)=ALPBPARM
111 S DIK="^ALPB(53.71,"_DA(1)_",1,"
112 D ^DIK
113 Q
114 ;
115PTLIST(LTYPE,RESULTS) ; get list of patients in file 53.7...
116 ; LTYPE = passed = "ALL" to list all patients or
117 ; = <wardname> to list patients on a selected ward
118 ; RESULTS = an array passed by reference in which data will be returned
119 N ALPBDATA,ALPBIEN,ALPBPTN,ALPBX
120 I $G(LTYPE)="" S LTYPE="ALL"
121 S ALPBX=0
122 I LTYPE="ALL" D
123 .S ALPBPTN=""
124 .F S ALPBPTN=$O(^ALPB(53.7,"B",ALPBPTN)) Q:ALPBPTN="" D
125 ..S ALPBIEN=0
126 ..F S ALPBIEN=$O(^ALPB(53.7,"B",ALPBPTN,ALPBIEN)) Q:'ALPBIEN D
127 ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
128 ...I ALPBDATA="" K ALPBDATA Q
129 ...S ALPBX=ALPBX+1
130 ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
131 ...K ALPBDATA
132 ..K ALPBIEN
133 .K ALPBPTN
134 I LTYPE'="ALL" D
135 .S ALPBPTN=""
136 .F S ALPBPTN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN)) Q:ALPBPTN="" D
137 ..S ALPBIEN=0
138 ..F S ALPBIEN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN,ALPBIEN)) Q:'ALPBIEN D
139 ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
140 ...I ALPBDATA="" K ALPBDATA Q
141 ...S ALPBX=ALPBX+1
142 ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
143 ...K ALPBDATA
144 ..K ALPBIEN
145 .K ALPBPTN
146 Q
147 ;
148STAT(ST) ;This will return the value of a status code for pharmacy
149 I $G(ST)="" Q ""
150 I $L($T(@ST)) G @ST
151 Q ""
152IP Q "pending"
153CM Q "finished/verified by pharmacist(active)"
154DC Q "discontinued"
155RP Q "replaced"
156HD Q "on hold"
157ZE Q "expired"
158ZS Q "suspended(active)"
159ZU Q "un-suspended(active)"
160ZX Q "unreleased"
161ZZ Q "renewed"
162 ;
163STAT2(CODE) ; convert order status code for output...
164 ; this function is used primarily by the workstation software
165 ; CODE = an order status code
166 ; returns printable status code
167 I $G(CODE)="" Q "Unknown"
168 I CODE="IP"!(CODE="ZX") Q "Pending"
169 I CODE="CM"!(CODE="ZU")!(CODE="ZZ") Q "Active"
170 I CODE="HD"!(CODE="ZS") Q "Hold"
171 I CODE="DC"!(CODE="RP")!(CODE="ZE") Q "Expired"
172 Q "Unknown"
173 ;
174DIV(DFN,ALPBMDT) ;get the Division for a patient
175 I +$G(DFN)'>0 Q ""
176 N ALPBDIV,ALPWRD,VAIN,VAINDT
177 S:+$G(ALPBMDT)>0 VAINDT=$P(ALPBMDT,".",1)
178 K ALPBMDT
179 D INP^VADPT
180 S ALPWRD=$P($G(VAIN(4)),U,1)
181 Q:+ALPWRD'>0 ""
182 ;Check to see if ward is a DOMICILIARY
183 I $P($G(^DIC(42,ALPWRD,0)),U,3)="D",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "DOM"
184 S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
185 Q:+ALPBDIV'>0 ""
186 Q ALPBDIV
187 ;
188CNV(A,B,X) ;CONVERT A STRING
189 ;This API will take a HL7 segment and convert characters
190 ;defined in the input
191 ;Example:
192 ;Single encoding characters can be converted such as ^ to ~
193 ;or multiple encoding characters can be converted such as
194 ; |~^@/ to ^~|/@
195 ;A is the string of HL7 encoding characters to be converted
196 ;B is the string of HL7 encoding characters to be converted to
197 ;X is te message string to be converted
198 I A=""!B=""!X="" Q ""
199 F I=1:1:$L(A) S A(I)=$E(A,I,I),A(I,1)=""
200 F I=1:1:$L(B) S B(I)=$E(B,I,I)
201 S J=0
202 F S J=$O(A(J)) Q:+J'>0 D
203 . F I=1:1:$L(X) S:$E(X,I,I)=A(J) A(J,1)=A(J,1)_I_U
204 S J=0
205 F S J=$O(A(J)) Q:+J'>0 D
206 . Q:'$D(A(J,1))!'$D(B(J))
207 . F I=1:1:$L(A(J,1),U) S C=$P(A(J,1),U,I) S:+C>0 $E(X,C,C)=B(J)
208 Q X
Note: See TracBrowser for help on using the repository browser.