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

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

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