source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL5.m@ 619

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

initial load of WorldVistAEHR
File size: 7.3 KB
RevLine 
[613]1ECXUTL5 ;ALB/JRC - Utilities for DSS Extracts ; 10/17/07 3:49pm
2 ;;3.0;DSS EXTRACTS;**71,84,92,103,105**;Dec 22, 1997;Build 70
3 ;
4REPEAT(CHAR,TIMES) ;REPEAT A STRING
5 ;INPUT : CHAR - Character to repeat
6 ; TIMES - Number of times to repeat CHAR
7 ;OUTPUT : s - String of CHAR that is TIMES long
8 ; "" - Error (bad input)
9 ;
10 ;CHECK INPUT
11 Q:($G(CHAR)="") ""
12 Q:((+$G(TIMES))=0) ""
13 ;RETURN STRING
14 Q $TR($J("",TIMES)," ",CHAR)
15INSERT(INSTR,OUTSTR,COLUMN,LENGTH) ;INSERT A STRING INTO ANOTHER
16 ;INPUT : INSTR - String to insert
17 ; OUTSTR - String to insert into
18 ; COLUMN - Where to begin insertion (defaults to end of OUTSTR)
19 ; LENGTH - Number of characters to clear from OUTSTR
20 ; (defaults to length of INSTR)
21 ;OUTPUT : s - INSTR will be placed into OUTSTR starting at COLUMN
22 ; using LENGTH characters
23 ; "" - Error (bad input)
24 ;
25 ;NOTE : This module is based on $$SETSTR^VALM1
26 ;
27 ;CHECK INPUT
28 Q:('$D(INSTR)) ""
29 Q:('$D(OUTSTR)) ""
30 S:('$D(COLUMN)) COLUMN=$L(OUTSTR)+1
31 S:('$D(LENGTH)) LENGTH=$L(INSTR)
32 ;DECLARE VARIABLES
33 N FRONT,END
34 S FRONT=$E((OUTSTR_$J("",COLUMN-1)),1,(COLUMN-1))
35 S END=$E(OUTSTR,(COLUMN+LENGTH),$L(OUTSTR))
36 ;INSERT STRING
37 Q FRONT_$E((INSTR_$J("",LENGTH)),1,LENGTH)_END
38TYPE(DFN) ;Determine patient type DBIA #2511
39 ; input
40 ; DFN = patient ien
41 ;
42 ; output
43 ; ECXPTYPE = patient type external value from fle 391
44 ;
45 ; AC = ACTIVE DUTY MI = MILITARY RETIREE
46 ; AL = ALLIED VETERAN NO = NON-VETERAN (OTHER)
47 ; CO = COLLATERAL NS = NSC VETERAN
48 ; EM = EMPLOYEE SC = SC VETERAN
49 ; IN = INELIGIBLE TR = TRICARE
50 ; return value 0 if no data found, 1 if data found
51 ;
52 N TYPE,ECXPTYPE
53 ;Check input
54 Q:'$D(DFN) ""
55 S (TYPE,ECXPTYPE)=""
56 S TYPE=$G(^DPT(DFN,"TYPE"))
57 I 'TYPE Q ECXPTYPE
58 S ECXPTYPE=$P($G(^DG(391,TYPE,0)),U,1)
59 S ECXPTYPE=$E(ECXPTYPE,1,2)
60 Q ECXPTYPE
61CVEDT(DFN,DATE) ;Determine patient CV status DBIA #4156
62 ; input
63 ; DFN = patient ien
64 ;
65 ; output
66 ; ECXCVE = combat veteran status eligibility
67 ; ECXCVEDT = combat veteran eligibility end date
68 ; ECXCVENC = combat veteran encounter
69 ;Initialize variables
70 N CVSTAT
71 S (CVSTAT,ECXCVE,ECXCVEDT,ECXCVENC)=""
72 ;Check input
73 Q:'$D(DFN) 0
74 ;Call CV API
75 S CVSTAT=$$CVEDT^DGCV(DFN,DATE)
76 I CVSTAT<1 Q 0
77 ;Veteran been given CV eligibility
78 S ECXCVE=$S($P(CVSTAT,U,3)=1:"Y",$P(CVSTAT,U,3)=0:"E",1:"")
79 ;Save CV eligibility end date and convert from FM to HL7 format
80 S ECXCVEDT=$P(CVSTAT,U,2)
81 S ECXCVEDT=$$FMTHL7^XLFDT(ECXCVEDT)
82 ;Is the veteran eligible for CV in the date of encounter
83 S ECXCVENC=$S($P(CVSTAT,U,3)=1:"Y",1:"")
84 Q 1
85NPRF ;National patient record flags DBIA #3860
86 N ECXARR,FLG
87 S ECXNPRFI="",CNT=$$GETACT^DGPFAPI(ECXDFN,"ECXARR"),FLG=""
88 I 'CNT Q
89 F I=1:1:CNT D Q:FLG
90 .I ECXARR(I,"CATEGORY")["NATIONAL" S ECXNPRFI="Y",FLG=1
91 Q
92RXPTST(K) ;Rx patient status DBIA #2511
93 N ECXDIC,STAT
94 S (ECXDIC,STAT)=""
95 ;Check input
96 Q:'$D(K) STAT
97 S DA=K,DIC="^PS(53,",DIQ(0)="I",DIQ="ECXDIC",DR="6"
98 D EN^DIQ1
99 S STAT=$G(ECXDIC(53,K,6,"I"))
100 S STAT=$S(STAT=1:"SC",STAT=2:"AA",STAT=3:"OTH",STAT=4:"INP",STAT=5:"NON",1:"")
101 Q STAT
102NONVAP(K) ;Non-va prescriber DBIA #10060
103 N ECXDIC,NONVAP
104 S (ECXDIC,NONVAP)=""
105 Q:'$D(K) NONVAP
106 S DA=K,DIC="^VA(200,",DIQ(0)="I",DIQ="ECXDIC",DR="53.91"
107 D EN^DIQ1
108 S NONVAP=$G(ECXDIC(200,K,53.91,"I"))
109 I NONVAP S NONVAP="Y"
110 Q NONVAP
111DOIVPO(K,L) ;Add destination for outpatient ivp orders
112 ; Input K - DFN
113 ; L - Order # from Pharmacy Patient File (#55)
114 ;
115 ; Output ordering stop code
116 ;
117 N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA
118 S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)=""
119 ;Check input
120 Q:'K!'(L) SCODE
121 ;Check treating specialty
122 S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE
123 ;Go to pharmacy patient file (#55) and return value of field (#136)
124 S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="100",DR(55.01)="136",DA=K,DA(55.01)=L
125 D EN^DIQ1
126 S CLINIC=$G(ECXDIC(55.01,L,136,"I"))
127 I 'CLINIC Q SCODE
128 ;Get stop code pointer to file 40.7 from file 44
129 S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1
130 S SCODE=ECXDICA(44,CLINIC,8,"I")
131 ;Get stop code external value
132 S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1
133 S SCODE=$G(ECXDICB(40.7,SCODE,1,"E"))
134 Q SCODE
135 ;
136DOUDO(K,L) ;Add destination for outpatient udp orders
137 ; Input K - DFN
138 ; L - Order # from Pharmacy Patient File (#55)
139 ;
140 ; Output ordering stop code
141 ;
142 N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA
143 S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)=""
144 ;Check treating specialty
145 S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE
146 ;Check input
147 Q:'K!'(L) SCODE
148 S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="62",DR(55.06)="130",DA=K,DA(55.06)=L
149 D EN^DIQ1
150 S CLINIC=$G(ECXDIC(55.06,L,130,"I"))
151 I 'CLINIC Q SCODE
152 ;Get stop code pointer to file 40.7 from file 44
153 S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1
154 S SCODE=ECXDICA(44,CLINIC,8,"I")
155 ;Get stop code external value
156 S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1
157 S SCODE=$G(ECXDICB(40.7,SCODE,1,"E"))
158 Q SCODE
159 ;
160PHAAPI(DRUG) ;Call Pharmacy drug file API dbia 4483
161 ; Input: drug file (#50) ien
162 ;
163 ; Output: generic name ^ classification ^ ndc ^ dea hand
164 ; ^ ndf file entry # ^ psndf va product entry ^
165 ; price per disp unit ^ dispense unit
166 ;
167 ;Initialize variables and scratch global
168 N NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,UNIT,ARRAY,DATA
169 S (NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,ARRAY,DATA)=""
170 S ARRAY="^TMP($J,""ECXLIST"")"
171 K @ARRAY
172 D DATA^PSS50(DRUG,,,,,"ECXLIST")
173 I @ARRAY@(0)'>0 Q "^^^^^^"
174 S NAME=@ARRAY@(DRUG,.01),CLASS=@ARRAY@(DRUG,2),NDC=@ARRAY@(DRUG,31)
175 S INV=@ARRAY@(DRUG,3),P1=$P(@ARRAY@(DRUG,20),U),P3=$P(@ARRAY@(DRUG,22),U),PPDU=@ARRAY@(DRUG,16),UNIT=@ARRAY@(DRUG,14.5)
176 K @ARRAY
177 Q NAME_U_CLASS_U_NDC_U_INV_U_P1_U_P3_U_PPDU_U_UNIT
178 ;
179TSSC(X) ;Check treating specialty (ts) and if ts equals any of the following
180 ;18,23,24,36,41,65,94 then assign predefined code and return value
181 ;
182 ; Input: treating specialty
183 ; Output: Ordering stop code
184 ;
185 S CODE=$S(X=18:293,X=23:295,X=24:290,X=36:294,X=41:296,X=65:291,X=94:292,1:"")
186 Q CODE
187 ;
188PSJ59P5(X) ;Get iv room division
189 ; Input X - iv room ien
190 ;
191 ; Output - field .02 division
192 ;Init variables
193 N DIV S DIV=""
194 ;Check input
195 I 'X Q DIV
196 D ALL^PSJ59P5(X,,"ECXDIV")
197 S DIV=$P($G(^TMP($J,"ECXDIV",X,.02)),U)
198 K ^TMP($J,"ECXDIV")
199 Q DIV
200 ;
201SCRX(IEN) ;Service connected prescription
202 ;Init variables
203 N DIC,DR,DA,ECXDIQ
204 ;Check input
205 I '$G(IEN) Q ""
206 S DIC=52,DR="116",DA=IEN,DIQ="ECXDIQ"
207 D DIQ^PSODI(DIC,DIC,DR,DA,DIQ)
208 Q $S($G(ECXDIQ(52,DA,116))="YES":"Y",$G(ECXDIQ(52,DA,116))="NO":"N",1:"")
209 ;
210SSN(SSN,FILE) ; extended validation of ssn
211 ; input: ssn - social security number to validate
212 ; file - optional "", 2 or 67, the only check is for
213 ; reference lab file (#67) in which case ssn
214 ; "000123456" is considered a valid ssn.
215 ; output: 0 - test patient or invalid ssn
216 ; 1 - valid ssn
217 ;
218 ;check input
219 I $G(SSN)']"" Q 0
220 S FILE=$G(FILE)
221 I (FILE=67)&(SSN="000123456") Q 1
222 I "89"[$E(SSN) Q 0
223 I (SSN="123456789")!(SSN="111111111")!(SSN="222222222")!(SSN="333333333")!(SSN="444444444")!(SSN="555555555")!($E(SSN,1,3)="666")!($E(SSN,4,5)="00")!($E(SSN,1,3)="000") Q 0
224 Q 1
Note: See TracBrowser for help on using the repository browser.