source: Scheduling/trunk/m/BSDX09.m@ 1308

Last change on this file since 1308 was 1187, checked in by Sam Habiel, 14 years ago

Changes to BSDX01 to prevent Scheduled,dc'ed,completed radiology appointments from being cancelled. Updated files to T2.
File size: 5.6 KB
Line 
1BSDX09 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; ; 4/28/11 10:18am
2 ;;1.6T2;BSDX;;May 16, 2011;Build 7
3 ; Licensed under LGPL
4 ;
5 ; Change Log:
6 ; UJO/TH - v 1.3 on 3100714 - Extra Demographics:
7 ; - Email
8 ; - Cell Phone
9 ; - Country
10 ; - + refactoring of routine
11 ;
12 ; UJO/TH - v 1.3 on 3100715 - Change SSN to PID and get PID field instead
13 ;
14 ; UJO/TH - v 1.42 on 3101020 - Add Sex field.
15 ;
16GETREGA(BSDXRET,BSDXPAT) ;EP
17 ;
18 ; See below for the returned fields
19 ;
20 ;For patient with ien BSDXPAT
21 ;K ^BSDXTMP($J)
22 S BSDXERR=""
23 S BSDXRET="^BSDXTMP("_$J_")"
24 ;
25 N OUT S OUT=$NA(^BSDXTMP($J,0))
26 S $P(@OUT,U,1)="T00030IEN"
27 S $P(@OUT,U,2)="T00030STREET"
28 S $P(@OUT,U,3)="T00030CITY"
29 S $P(@OUT,U,4)="T00030STATE"
30 S $P(@OUT,U,5)="T00030ZIP"
31 S $P(@OUT,U,6)="T00030NAME"
32 S $P(@OUT,U,7)="D00030DOB"
33 S $P(@OUT,U,8)="T00030PID"
34 S $P(@OUT,U,9)="T00030HRN"
35 S $P(@OUT,U,10)="T00030HOMEPHONE"
36 S $P(@OUT,U,11)="T00030OFCPHONE"
37 S $P(@OUT,U,12)="T00030MSGPHONE"
38 S $P(@OUT,U,13)="T00030NOK NAME"
39 S $P(@OUT,U,14)="T00030RELATIONSHIP"
40 S $P(@OUT,U,15)="T00030PHONE"
41 S $P(@OUT,U,16)="T00030STREET"
42 S $P(@OUT,U,17)="T00030CITY"
43 S $P(@OUT,U,18)="T00030STATE"
44 S $P(@OUT,U,19)="T00030ZIP"
45 S $P(@OUT,U,20)="D00030DATAREVIEWED"
46 S $P(@OUT,U,21)="T00030RegistrationComments"
47 S $P(@OUT,U,22)="T00050EMAIL ADDRESS"
48 S $P(@OUT,U,23)="T00020PHONE NUMBER [CELLULAR]"
49 S $P(@OUT,U,24)="T00030COUNTRY"
50 S $P(@OUT,U,25)="T00030SEX"
51 S $E(@OUT,$L(@OUT)+1)=$C(30)
52 ;
53 ;
54 N BSDXNOD,BSDXNAM,Y,U
55 S U="^"
56 S BSDXY="ERROR"
57 K NAME
58 I '+BSDXPAT S ^BSDXTMP($J,1)=$C(31) Q
59 I '$D(^DPT(+BSDXPAT,0)) S ^BSDXTMP($J,1)=$C(31) Q
60 S BSDXY=""
61 S $P(BSDXY,U)=BSDXPAT
62 ;//smh S $P(BSDXY,U,23)=""
63 S $P(BSDXY,U,21)=""
64 S BSDXNOD=^DPT(+BSDXPAT,0)
65 S $P(BSDXY,"^",6)=$P(BSDXNOD,U) ;NAME
66 S $P(BSDXY,"^",8)=$$GET1^DIQ(2,BSDXPAT,"PRIMARY LONG ID") ;PID
67 S Y=$P(BSDXNOD,U,3) I Y]"" X ^DD("DD") S Y=$TR(Y,"@"," ")
68 S $P(BSDXY,"^",7)=Y ;DOB
69 S $P(BSDXY,"^",9)=""
70 I $D(DUZ(2)) I DUZ(2)>0 S $P(BSDXY,"^",9)=$P($G(^AUPNPAT(BSDXPAT,41,DUZ(2),0)),U,2) ;HRN
71 D MAIL
72 D PHONE
73 D NOK
74 D DATAREV
75 ;/smh D MEDICARE
76 D REGCMT
77 S $P(BSDXY,"^",22)=$$GET1^DIQ(2,BSDXPAT,"EMAIL ADDRESS")
78 S $P(BSDXY,"^",23)=$$GET1^DIQ(2,BSDXPAT,"PHONE NUMBER [CELLULAR]")
79 S $P(BSDXY,"^",24)=$$GET1^DIQ(2,BSDXPAT,"COUNTRY:DESCRIPTION")
80 S $P(BSDXY,"^",25)=$$GET1^DIQ(2,BSDXPAT,"SEX")
81 N BSDXBEG,BSDXEND,BSDXLEN,BSDXI
82 S BSDXLEN=$L(BSDXY)
83 S BSDXBEG=0,BSDXI=2
84 F D Q:BSDXEND=BSDXLEN
85 . S BSDXEND=BSDXBEG+100
86 . S:BSDXEND>BSDXLEN BSDXEND=BSDXLEN
87 . S BSDXI=BSDXI+1
88 . S ^BSDXTMP($J,BSDXI)=$E(BSDXY,BSDXBEG,BSDXEND)
89 . S BSDXBEG=BSDXBEG+101
90 S ^BSDXTMP($J,BSDXI+1)=$C(30)_$C(31)
91 Q
92 ;
93MAIL N BSDXST
94 Q:'$D(^DPT(+BSDXPAT,.11))
95 S BSDXNOD=^DPT(+BSDXPAT,.11)
96 Q:BSDXNOD=""
97 S $P(BSDXY,"^",2)=$E($P(BSDXNOD,U),1,50) ;STREET
98 S $P(BSDXY,"^",3)=$P(BSDXNOD,U,4) ;CITY
99 S BSDXST=$P(BSDXNOD,U,5)
100 I +BSDXST,$D(^DIC(5,+BSDXST,0)) S BSDXST=$P(^DIC(5,+BSDXST,0),U,2)
101 S $P(BSDXY,"^",4)=BSDXST ;STATE
102 S $P(BSDXY,"^",5)=$P(BSDXNOD,U,6) ;ZIP
103 Q
104 ;
105PHONE ;PHONE 10,11,12 HOME,OFC,MSG
106 I $D(^DPT(+BSDXPAT,.13)) D
107 . S BSDXNOD=^DPT(+BSDXPAT,.13)
108 . S $P(BSDXY,U,10)=$P(BSDXNOD,U,1)
109 . S $P(BSDXY,U,11)=$P(BSDXNOD,U,2)
110 I $D(^DPT(+BSDXPAT,.121)) D
111 . S BSDXNOD=^DPT(+BSDXPAT,.121)
112 . S $P(BSDXY,U,12)=$P(BSDXNOD,U,10)
113 Q
114 ;
115NOK ;NOK
116 ; 13 NOK NAME^RELATIONSHIP^PHONE^STREET^CITY^STATE^ZIP
117 N Y,BSDXST
118 I $D(^DPT(+BSDXPAT,.21)) D
119 . S BSDXNOD=^DPT(+BSDXPAT,.21)
120 . S $P(BSDXY,U,13)=$P(BSDXNOD,U,1)
121 . S $P(BSDXY,U,14)=$$VAL^XBDIQ1(9000001,BSDXPAT,2802)
122 . S $P(BSDXY,U,15)=$P(BSDXNOD,U,9)
123 . S $P(BSDXY,U,16)=$P(BSDXNOD,U,3)
124 . S $P(BSDXY,U,17)=$P(BSDXNOD,U,6)
125 . S BSDXST=$P(BSDXNOD,U,7)
126 . I +BSDXST D
127 . . I $D(^DIC(5,+BSDXST,0)) S BSDXST=$P(^DIC(5,+BSDXST,0),U,2),$P(BSDXY,U,18)=BSDXST
128 . S $P(BSDXY,U,19)=$P(BSDXNOD,U,8)
129 Q
130 ;
131DATAREV S $P(BSDXY,U,20)=$P($$VAL^XBDIQ1(9000001,BSDXPAT,16651),"@")
132 Q
133 ;
134REGCMT N BSDXI,BSDXM,BSDXR
135 S BSDXR=""
136 D ENP^XBDIQ1(9000001,BSDXPAT,1301,"BSDXM(")
137 S BSDXI=0 F S BSDXI=$O(BSDXM(1301,BSDXI)) Q:'+BSDXI D
138 . S BSDXR=BSDXR_" "_BSDXM(1301,BSDXI)
139 ; S $P(BSDXY,U,23)=$TR($E(BSDXR,1,1024),U," ") ; MJL 1/17/2007 //smh
140 S $P(BSDXY,U,21)=$TR($E(BSDXR,1,1024),U," ") ;
141 Q
142 ;
143GETMCAID(BSDXY,BSDXPAT) ; not in wv
144 ;Returns PATIENTIEN^ENTRY#^MEDICAID#^SUBENTRY#^ELIG.BEGIN^ELIG.END |
145 ;File is not dinum
146 N C,N,ASDGX,BSDXM,BSDXBLD,BSDXCNT
147 N BSDXIEN
148 S BSDXBLD=""
149 S BSDXIEN=0
150 S BSDXCNT=1
151 F S BSDXIEN=$O(^AUPNMCD("B",BSDXPAT,BSDXIEN)) Q:'+BSDXIEN D
152 . S BSDXNUM=$$VAL^XBDIQ1(9000004,BSDXIEN,.03) ;MCAID#
153 . D ENPM^XBDIQ1(9000004.11,BSDXIEN_",0",".01:.02","ASDGX(")
154 . S C=1,N=0,BSDXM=""
155 . F S N=$O(ASDGX(N)) Q:'N D
156 . . S $P(BSDXY,"|",C)=BSDXPAT_U_BSDXIEN_U_BSDXNUM_U_N_U_ASDGX(N,.01)_U_ASDGX(N,.02)
157 . . S C=C+1
158 . . Q
159 . Q
160 Q
161 ;
162MEDICARE ; not in WV
163 S $P(BSDXY,U,21)=$$VAL^XBDIQ1(9000003,BSDXPAT,.03)
164 S $P(BSDXY,U,22)=$$VAL^XBDIQ1(9000003,BSDXPAT,.04)
165 Q
166 ;
167GETMCARE(BSDXY,BSDXPAT) ;
168 ;Returns IEN^MEDICARE#^SUFFIX^SUBENTRY#^TYPE^ELIG.BEGIN^ELIG.END |
169 ;File is dinum
170 ;
171 N ASDGX,C,N,BSDXNUM,BSDXSUF,BSDXBLD
172 S BSDXNUM=$$VAL^XBDIQ1(9000003,BSDXPAT,.03)
173 S BSDXSUF=$$VAL^XBDIQ1(9000003,BSDXPAT,.04)
174 D ENPM^XBDIQ1(9000003.11,BSDXPAT_",0",".01:.03","ASDGX(")
175 S C=1,N=0,BSDXBLD=""
176 F S N=$O(ASDGX(N)) Q:'N D
177 . S $P(BSDXY,"|",C)=BSDXPAT_U_BSDXNUM_U_BSDXSUF_U_N_U_ASDGX(N,.03)_U_ASDGX(N,.01)_U_ASDGX(N,.02)
178 . S C=C+1
179 . Q
180 Q
181 ;
182GETPVTIN(BSDXY,BSDXPAT) ;
183 ;Returns IEN^SUBENTRY^INSURER^POLICYNUMBER^ELIG.BEGIN^ELIG.END|...
184 ;File is dinum
185 ;
186 N ASDGX,C,N
187 D ENPM^XBDIQ1(9000006.11,BSDXPAT_",0",".01;.02;.06;.07","ASDGX(")
188 S C=1,N=0
189 F S N=$O(ASDGX(N)) Q:'N D
190 . S $P(BSDXY,"|",C)=BSDXPAT_U_N_U_ASDGX(N,.01)_U_ASDGX(N,.02)_U_ASDGX(N,.06)_U_ASDGX(N,.07)
191 . S C=C+1
192 . Q
193 Q
194 ;
195DFN(FILE,BSDXPAT) ; -- returns ien for file
196 I FILE'[9000004 Q BSDXPAT
197 Q +$O(^AUPNMCD("B",BSDXPAT,0))
Note: See TracBrowser for help on using the repository browser.