source: WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/CRHDUD.m@ 1006

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

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1CRHDUD ;CAIRO/CLC - New Person general information ;04-Mar-2008 16:00;CLC;EMPLOYEE DIRECTORY
2 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
3DISPEMP(CRHDRTN,CRHDEMP) ;
4 K CRHDRTN
5 N CRHDUIF
6 D DISP(.CRHDUIF,+CRHDEMP)
7 I $D(CRHDUIF) S CRHDRTN(1)=CRHDUIF
8 Q
9DISP(CRHDRTN,CRHDEMP) ;
10 ;COLUMNS
11 ;DUZ^NAME^SITE^TITLE^OFFICE PH^PAGER^RM^EMAIL^SRV^MAIL CODE
12 N CRHDEXT,CRHDSF,CRHDPG,CRHDRM,CRHDNAM,CRHDTIT,CRHDSRV,CRHDSMC,CRHDSRM,CRHDFAX,CRHDEM
13 N CRHDSRVN,CRHDMC
14 ;
15 K CRHDRTN
16 I $$GET1^DIQ(200,+CRHDEMP,.01,"I")="" Q
17 S CRHDNAM=$$GET1^DIQ(200,+CRHDEMP_",",.01,"E")
18 I $L(CRHDNAM)<2 Q
19 I '$$ACTIVE^XUSER(+CRHDEMP) S CRHDNAM=CRHDNAM_" (NOT AN ACTIVE USER)"
20 S CRHDTIT=$$GET1^DIQ(200,+CRHDEMP_",",8,"E")
21 S CRHDMC=$$GET1^DIQ(200,+CRHDEMP_",",28,"E") ;MAIL CODE
22 S CRHDEXT=$$GET1^DIQ(200,+CRHDEMP_",",.132,"E") ;OFFICE PHONE
23 S CRHDPG=$$GET1^DIQ(200,+CRHDEMP_",",.138,"E") ;PAGER
24 S CRHDEM=$$GET1^DIQ(200,+CRHDEMP_",",.151,"E") ;EMAIL ADDRESS
25 S CRHDRM=$$GET1^DIQ(200,+CRHDEMP_",",.141,"E") ;ROOM
26 S CRHDFAX=$$GET1^DIQ(200,+CRHDEMP_",",.136,"E") ;FAX
27 S CRHDSRV=$$GET1^DIQ(200,+CRHDEMP_",",29,"E") ;SERVICE
28 S CRHDSRVN=$$GET1^DIQ(200,+CRHDEMP_",",29,"I") ;SERVICE IEN
29 ;SERVICE INFORMATION
30 S CRHDSMC=$$GET1^DIQ(49,+CRHDSRVN_",",1.5,"E") ;SERVICE MAIL CODE
31 S CRHDSRM=$$GET1^DIQ(200,+CRHDSRVN_",",6,"E") ;SERVICE LOCATION
32 ;DISPLAY INFORMATION
33 S CRHDRTN=+CRHDEMP_"^"_CRHDNAM
34 S $P(CRHDRTN,"^",3)=$$TITLE^XLFSTR(CRHDTIT)
35 S $P(CRHDRTN,"^",4)=CRHDEXT
36 S $P(CRHDRTN,"^",5)=CRHDPG
37 S $P(CRHDRTN,"^",6)=CRHDRM
38 S $P(CRHDRTN,"^",7)=CRHDEM
39 S $P(CRHDRTN,"^",8)=CRHDFAX
40 S $P(CRHDRTN,"^",9)=CRHDSRV
41 S $P(CRHDRTN,"^",10)=CRHDSMC
42 ;S $P(CRHDRTN,"^",11)=CRHDSRM
43 S $P(CRHDRTN,"^",11)=$TR($P($$SITE^VASITE,"^",2,3),"^","-")
44 Q
45SRV(CRHDRTN,CRHDSRVN,CRHDDIV) ;
46 K CRHDRTN
47 N CRHDUIF,CRHDUSR,CRHDS,CRHDCT,CRHDX,CRHDSORT
48 I $D(^VA(200,"E")) D
49 .S CRHDUSR=0
50 .F S CRHDUSR=$O(^VA(200,"E",+CRHDSRVN,CRHDUSR)) Q:'CRHDUSR D
51 ..I $$ACTIVE^XUSER(CRHDUSR) D
52 ...K CRHDUIF
53B ...D DISP(.CRHDUIF,CRHDUSR)
54 ...I $D(CRHDUIF) S:$P(CRHDUIF,"^",3)'="" CRHDSORT($P(CRHDUIF,"^",2))=CRHDUIF
55 ;COLUMNS - SEE ABOVE USER
56 ;
57 ;DISPLAY INFORMATION
58 I $D(CRHDSORT) D
59 .S CRHDX=""
60 .S CRHDCT=0
61 .F S CRHDX=$O(CRHDSORT(CRHDX)) Q:CRHDX="" D
62 ..S CRHDCT=CRHDCT+1
63 ..S CRHDRTN(CRHDCT)=CRHDSORT(CRHDX)
64 Q
65SPEC(CRHDRTN,CRHDSP) ;
66 N CRHDCT,X,CRHDX,CRHDPRV,CRHDPG,CRHDNAM,CRHDS,CRHDUIF,CRHDSORT
67 K CRHDRTN
68 ;S S=" "
69 ;S CRHDRTN(1)="Specialty: "_$C(9)_$$GET1^DIQ(45.7,+CRHDSP_",",.01,"E")
70 ;S CRHDRTN(2)=""
71 ;S CRHDRTN(3)="No provider Found."
72 ;S CT=2
73 I $D(^DIC(45.7,+CRHDSP,"PRO")) D
74 .S X=0
75 .F S X=$O(^DIC(45.7,+CRHDSP,"PRO",X)) Q:'X D
76 ..Q:'$$ACTIVE^XUSER(X)
77 ..S CRHDPRV=+$G(^DIC(45.7,+CRHDSP,"PRO",X,0))
78 ..D DISP(.CRHDUIF,+CRHDPRV)
79 ..I $D(CRHDUIF) S CRHDSORT($P(CRHDUIF,"^",2))=CRHDUIF
80 I $D(CRHDSORT) D
81 .S CRHDCT=0
82 .S CRHDX=""
83 .F S CRHDX=$O(CRHDSORT(CRHDX)) Q:CRHDX="" D
84 ..S CRHDCT=CRHDCT+1
85 ..S CRHDRTN(CRHDCT)=CRHDSORT(CRHDX)
86 Q
87HOTEAM(CRHDRTN,CRHDTM) ;
88 ;Get HOTeam phone list
89 N CRHDX,CRHDPRV,CRHDCT,CRHDSORT,CRHDUIF
90 K CRHDRTN
91 I '$D(^CRHD(183.3,"B",$P(CRHDTM,"^",2),+CRHDTM)) Q
92 S CRHDX=0
93 F S CRHDX=$O(^CRHD(183.3,+CRHDTM,2,CRHDX)) Q:'CRHDX D
94 .S CRHDPRV=+$G(^CRHD(183.3,+CRHDTM,2,CRHDX,0))
95 .D DISP(.CRHDUIF,+CRHDPRV)
96 .I $D(CRHDUIF) S CRHDSORT($P(CRHDUIF,"^",2))=CRHDUIF
97 I $D(CRHDSORT) D
98 .S CRHDCT=0
99 .S CRHDX=""
100 .F S CRHDX=$O(CRHDSORT(CRHDX)) Q:CRHDX="" D
101 ..S CRHDCT=CRHDCT+1
102 ..S CRHDRTN(CRHDCT)=CRHDSORT(CRHDX)
103 Q
Note: See TracBrowser for help on using the repository browser.