source: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/CRHD9.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 8.4 KB
Line 
1CRHD9 ; CAIRO/CLC - HANDOFF TEAM LIST ;4/24/08 12:49
2 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
3 ;=================================================================
4HOTMSAVE(CRHDRTN,CRHDTM) ;
5 ;create a team name
6 N CRHDFDA,CRHDOUT,CRHDERR
7 K CRHDRTN
8 S CRHDRTN=0
9 I (CRHDTM'?1A.E)&(CRHDTM'?1N.E) Q
10 S CRHDFDA(183.3,"?+1,",.01)=CRHDTM
11 D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
12 I '$D(CRHDERR) S CRHDRTN=CRHDOUT(1)
13 Q
14HOTMDEL(CRHDRTN,CRHDTM) ;
15 ;delete a Hand off team
16 N DIK,DA
17 K CRHDRTN
18 S CRHDRTN=0
19 I +CRHDTM S DIK="^CRHD(183.3,",DA=+CRHDTM D ^DIK S CRHDRTN=1
20 Q
21HOLIST(CRHDRTN) ;
22 ;return a list of teams
23 N CRHDX,CRHDX1,CRHDTDT,CRHDCT
24 K CRHDRTN
25 S CRHDX=""
26 S CRHDCT=0
27 S CRHDRTN(0)="0^No List Found"
28 F S CRHDX=$O(^CRHD(183.3,"B",CRHDX)) Q:CRHDX="" D
29 .S CRHDX1=0
30 .F S CRHDX1=$O(^CRHD(183.3,"B",CRHDX,CRHDX1)) Q:'CRHDX1 D
31 ..;check to see if team list is active, if date is less then today then inactive
32 ..S CRHDTDT=$P($G(^CRHD(183.3,CRHDX1,0)),"^",2)
33 ..I CRHDTDT&(CRHDTDT<$$DT^XLFDT) Q
34 ..S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDX1_"^"_CRHDX_"^"_"HOTEAM"
35 I CRHDCT>0 K CRHDRTN(0)
36 Q
37HOPLIST(CRHDRTN,CRHDTM) ;
38 ;Get list of Patients for a HO team
39 N CRHDX,CRHDPT,CRHDPD,CRHDTLST,CRHDCT,CRHDPD2,VAIP,DFN,DIE,DA,DR
40 K CRHDRTN
41 S CRHDRTN(1)="No Patients Found"
42 Q:'CRHDTM
43 I '$D(^CRHD(183.3,"B",$P(CRHDTM,"^",2),+CRHDTM)) Q
44 S CRHDX=0
45 F S CRHDX=$O(^CRHD(183.3,+CRHDTM,1,CRHDX)) Q:'CRHDX D
46 .S CRHDPT=+$G(^CRHD(183.3,+CRHDTM,1,CRHDX,0))
47 .;check to see if patient has been discharged, if so delete from list
48 .S DFN=CRHDPT D IN5^VADPT
49 .I VAIP(1)="" D Q
50 ..S DA(1)=+CRHDTM,DIE="^CRHD(183.3,"_DA(1)_",1,",DA=CRHDX,DR=".01///@" D ^DIE
51 .S CRHDPD=$$PATDATA(CRHDPT)
52 .K CRHDPD2
53 .D PATPRV(.CRHDPD2,CRHDTM,CRHDPT)
54 .I $P(CRHDPD,"^",2)'="" S CRHDTLST($P(CRHDPD,"^",2))=CRHDPD
55 .I $G(CRHDPD2)'="" S CRHDTLST($P(CRHDPD,"^",2))=CRHDTLST($P(CRHDPD,"^",2))_"^*"_CRHDPD2
56 I $D(CRHDTLST) D
57 .S CRHDCT=0
58 .S CRHDX=""
59 .F S CRHDX=$O(CRHDTLST(CRHDX)) Q:CRHDX="" S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDTLST(CRHDX)
60 Q
61PATDATA(DFN) ;
62 ;
63 N CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE,CRHDSEX,VAIP,VADM
64 K VAIP,VADM
65 D DEM^VADPT,IN5^VADPT
66 S CRHDNAME=VADM(1),CRHDSSN=$P(VADM(2),U,1),CRHDDOB=$P(VADM(3),U,1)
67 S CRHDAGE=VADM(4),CRHDSEX=$P(VADM(5),U,1)
68 K VAIP,VADM
69 Q DFN_U_CRHDNAME_U_CRHDSSN_U_CRHDDOB_U_CRHDAGE_U_CRHDSEX
70 ;
71HODLIST(CRHDRTN,CRHDTM) ;Get list of Providers for a HO team
72 N CRHDX,CRHDPRV,CRHDTLST,CRHDCT,CRHDZ0,CRHDSORT,CRHDUT
73 N CRHDPX,CRHDPX0,CRHDNAM
74 K CRHDRTN
75 I '$D(^CRHD(183.3,"B",$P(CRHDTM,"^",2),+CRHDTM)) Q
76 S CRHDX=0
77 F S CRHDX=$O(^CRHD(183.3,+CRHDTM,2,CRHDX)) Q:'CRHDX D
78 .S CRHDPRV=+$G(^CRHD(183.3,+CRHDTM,2,CRHDX,0))
79 .S CRHDNAM=$$GET1^DIQ(200,+CRHDPRV,.01,"E")
80 .;Delete Provider if inactive, 1st check to see if assigned to a patient, if so remove
81 .I '$$ACTIVE^XUSER(+CRHDPRV) D Q
82 ..S CRHDPX=0 F S CRHDPX=$O(^CRHD(183.3,+CRHDTM,1,CRHDPX)) Q:'CRHDPX D
83 ...S CRHDPX0=^CRHD(183.3,+CRHDTM,1,CRHDPX,0)
84 ...I CRHDPX0[+CRHDPRV F CRHDI=2:1:$L(CRHDPX0,"^") I $P(CRHDPX0,"^",CRHDI)=+CRHDPRV S $P(^CRHD(183.3,+CRHDTM,1,CRHDPX,0),"^",CRHDI)=""
85 ..S DA(1)=+CRHDTM,DIE="^CRHD(183.3,"_DA(1)_",2,",DA=CRHDX,DR=".01///@" D ^DIE
86 .I CRHDNAM'="" D
87 ..S CRHDZ0=$G(^CRHD(183.3,+CRHDTM,2,+CRHDX,0))
88 ..S CRHDUT=$P(CRHDZ0,"^",2)
89 ..I CRHDUT="" S CRHDUT="ZNOTYPE"
90 ..S CRHDSORT(CRHDUT,CRHDNAM)=CRHDPRV_"^"_CRHDNAM_"^"_$P(CRHDZ0,"^",2)_"^"_+$P(CRHDZ0,"^",3)_"^"_+$P(CRHDZ0,"^",4)_"^"_$P(CRHDZ0,"^",5)_"^"_$P(CRHDZ0,"^",6)
91 S CRHDI=""
92 F S CRHDI=$O(CRHDSORT(CRHDI)) Q:CRHDI="" D
93 .S CRHDPRV=""
94 .F S CRHDPRV=$O(CRHDSORT(CRHDI,CRHDPRV)) Q:CRHDPRV="" D
95 ..S CRHDTLST(CRHDPRV)=CRHDSORT(CRHDI,CRHDPRV)
96 ..;S CRHDTLST(CRHDNAM)=CRHDPRV_"^"_CRHDNAM_"^"_$P(CRHDZ0,"^",2)_"^"_+$P(CRHDZ0,"^",3)_"^"_+$P(CRHDZ0,"^",4)_"^"_$P(CRHDZ0,"^",5)_"^"_$P(CRHDZ0,"^",6)
97 I $D(CRHDTLST) D
98 .S CRHDCT=0
99 .S CRHDX=""
100 .F S CRHDX=$O(CRHDTLST(CRHDX)) Q:CRHDX="" S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDTLST(CRHDX)
101 Q
102CANEDIT(CRHDRTN,CRHDTM,DUZ) ;
103 ;Can user edit team list
104 N CRHDPRV,CRHDMGR,CRHDA
105 Q:CRHDTM=""
106 ;S CRHDRTN="1^1"
107 S CRHDA=$$GET1^DIQ(200,+DUZ,3,"I")
108 S CRHDRTN="0^0"
109 I CRHDA["@" S CRHDRTN="1^1" Q
110 D HOTMMGR^CRHD1(.CRHDMGR,DUZ)
111 I CRHDMGR S CRHDRTN="1^1" Q
112 S CRHDPRV=$O(^CRHD(183.3,+CRHDTM,2,"B",+DUZ,0))
113 I 'CRHDPRV Q
114 E S CRHDRTN=+$P($G(^CRHD(183.3,+CRHDTM,2,+CRHDPRV,0)),"^",3)_"^"_+$P($G(^CRHD(183.3,+CRHDTM,2,+CRHDPRV,0)),"^",4)
115 Q
116PATPRV(CRHDRTN,CRHDTM,CRHDDFN) ;
117 ;return Providers assigned to patient on list
118 N CRHDPAT,CRHDNAM,CRHDZ0,CRHDP,CRHDATTN,CRHDRES,CRHDINT,CRHDFEL,CRHDMST,CRHDNUR,CRHDVP,CRHDI,CRHDI2
119 S CRHDVP="^CRHDATTN^CRHDRES^CRHDINT^CRHDFEL^CRHDMST^CRHDNUR"
120 S CRHDPAT=$O(^CRHD(183.3,+CRHDTM,1,"B",+CRHDDFN,0))
121 I 'CRHDPAT Q
122 S CRHDZ0=$G(^CRHD(183.3,+CRHDTM,1,+CRHDPAT,0))
123 ;I need to add, if the physician is not on team list delete from patient.
124 F CRHDI=2:1:7 S CRHDP=$P(CRHDZ0,"^",CRHDI) D
125 .I '$D(@$P(CRHDVP,"^",CRHDI)) S @$P(CRHDVP,"^",CRHDI)=""
126 .I CRHDP["," D
127 ..F CRHDI2=1:1:$L(CRHDP,",") D
128 ...I '$D(^CRHD(183.3,CRHDTM,2,"B",$P(CRHDP,",",CRHDI2))) Q
129 ...S CRHDNAM=$$GET1^DIQ(200,+$P(CRHDP,",",CRHDI2),.01,"E")
130 ...S @$P(CRHDVP,"^",CRHDI)=@$P(CRHDVP,"^",CRHDI)_+$P(CRHDP,",",CRHDI2)_"^"_CRHDNAM_"+"
131 .;E S:+CRHDP&($D(^CRHD(183.3,+CRHDTM,2,"B",+CRHDP))) @$P(CRHDVP,"^",CRHDI)=+CRHDP_"^"_$$GET1^DIQ(200,+CRHDP,.01,"E")
132 .E S:+CRHDP @$P(CRHDVP,"^",CRHDI)=+CRHDP_"^"_$$GET1^DIQ(200,+CRHDP,.01,"E")
133 F CRHDI=2:1:7 I $E(@$P(CRHDVP,"^",CRHDI),$L(@$P(CRHDVP,"^",CRHDI)))="+" S @$P(CRHDVP,"^",CRHDI)=$E(@$P(CRHDVP,"^",CRHDI),1,$L(@$P(CRHDVP,"^",CRHDI))-1)
134 S CRHDRTN=CRHDDFN_";"_$G(CRHDATTN)_";"_$G(CRHDRES)_";"_$G(CRHDINT)_";"_$G(CRHDFEL)_";"_$G(CRHDMST)_";"_$G(CRHDNUR)
135 Q
136USERPHPG(CRHDRTN,DUZ) ;
137 N CRHDOP,CRHDPG
138 S CRHDOP=$$GET1^DIQ(200,+DUZ_",",.132,"E") ;OFFICE PHONE
139 S CRHDPG=$$GET1^DIQ(200,+DUZ_",",.138,"E") ;PAGER
140 S CRHDRTN=$S($L(CRHDOP)>2:CRHDOP,1:"")_"^"_$S($L(CRHDPG)>2:CRHDPG,1:"")
141 Q
142PRVINFO(CRHDRTN,CRHDTM,DUZ) ;
143 ;return user information
144 N CRHDPRV,CRHDZ0,CRHDMGR
145 Q:CRHDTM=""
146 ;S CRHDRTN(1)="0^0"
147 S CRHDPRV=$O(^CRHD(183.3,+CRHDTM,2,"B",+DUZ,0))
148 I 'CRHDPRV Q
149 S CRHDZ0=$G(^CRHD(183.3,+CRHDTM,2,+CRHDPRV,0))
150 D MGR^CRHD7(.CRHDMGR,DUZ)
151 I ($$GET1^DIQ(200,+DUZ,3,"E")["@")!(+CRHDMGR) S $P(CRHDZ0,"^",3)=1,$P(CRHDZ0,"^",4)=1
152 S CRHDRTN=$P(CRHDZ0,"^",1)_"^"_$$GET1^DIQ(200,+CRHDZ0,.01,"E")_"^"_$P(CRHDZ0,"^",2,$L(CRHDZ0,"^"))
153 Q
154MOD(CRHDRTN,CRHDTM,CRHDLTYP,CRHDTXT,CRHDKFG) ;
155 N CRHDX,CRHDFDA,CRHDOUT,CRHDERR
156 K CRHDRTN
157 S CRHDRTN(0)=0
158 I '$D(^CRHD(183.3,"B",$P(CRHDTM,"^",2),+CRHDTM)) Q
159 I CRHDLTYP="P" D
160 .K:CRHDKFG ^CRHD(183.3,+CRHDTM,1)
161 .S CRHDX=0
162 .F S CRHDX=$O(CRHDTXT(CRHDX)) Q:'CRHDX D
163 ..I CRHDTXT(CRHDX)["~" S CRHDTXT(CRHDX)=$P(CRHDTXT(CRHDX),"~",2)
164 ..S CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",.01)=+$P(CRHDTXT(CRHDX),"^",1)
165 ..S CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",1)=+$P(CRHDTXT(CRHDX),";",2)
166 ..S CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",2)=+$P(CRHDTXT(CRHDX),";",3)
167 ..S CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",3)=+$P(CRHDTXT(CRHDX),";",4)
168 ..S CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",4)=+$P(CRHDTXT(CRHDX),";",5)
169 ..S CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",5)=+$P(CRHDTXT(CRHDX),";",6)
170 ..S CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",6)=+$P(CRHDTXT(CRHDX),";",7)
171 .D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
172 .I '$D(CRHDERR) S CRHDRTN(0)=1
173 .E S CRHDRTN(1)=1
174 I CRHDLTYP="D" D
175 .K:CRHDKFG ^CRHD(183.3,+CRHDTM,2)
176 .S CRHDX=0
177 .F S CRHDX=$O(CRHDTXT(CRHDX)) Q:'CRHDX D
178 ..I CRHDTXT(CRHDX)["~" S CRHDTXT(CRHDX)=$P(CRHDTXT(CRHDX),"~",2)
179 ..S CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",.01)=$P(CRHDTXT(CRHDX),"^",1)
180 ..S CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",1)=$P(CRHDTXT(CRHDX),"^",3)
181 ..S CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",2)=$P(CRHDTXT(CRHDX),"^",4)
182 ..S CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",3)=$P(CRHDTXT(CRHDX),"^",5)
183 ..S CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",4)=$P(CRHDTXT(CRHDX),"^",6)
184 ..S CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",5)=$P(CRHDTXT(CRHDX),"^",7)
185 .D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
186 .I '$D(CRHDERR) S CRHDRTN(0)=1
187 .E S CRHDRTN(1)=1
188 K CRHDFDA,CRHDOUT,CRHDERR
189 Q
190FILENSAV(CRHDRTN,CRHDTM,CRHDFNM) ;
191 ;save filename for a team
192 N CRHDFDA,CRHDOUT,CRHDERR,CRHDA
193 K CRHDRTN
194 S CRHDRTN=0
195 ;I CRHDTM'?1A.E Q
196 S CRHDFDA(183.4,"?+1,",.01)=$P(CRHDTM,"^",2)
197 D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
198 I '$D(CRHDERR) D
199 .S CRHDA=CRHDOUT(1)
200 .K CRHDFDA,CRHDOUT
201 .I CRHDA D
202 ..S CRHDFDA(183.4,CRHDA_",",2)=CRHDFNM
203 ..D FILE^DIE("","CRHDFDA")
204 ..S CRHDRTN=1
205 Q
206FILENGET(CRHDRTN,CRHDTM) ;
207 ;get filename for a team
208 S CRHDRTN=$$GET1^DIQ(183.4,+$$FIND1^DIC(183.4,"","X",$P(CRHDTM,"^",2),"","","ERR")_",",2,"I")
209 Q
Note: See TracBrowser for help on using the repository browser.