CRHDUD ;CAIRO/CLC - New Person general information ;04-Mar-2008 16:00;CLC;EMPLOYEE DIRECTORY
;;1.0;CRHD;****;Jan 28, 2008;Build 19
DISPEMP(CRHDRTN,CRHDEMP) ;
K CRHDRTN
N CRHDUIF
D DISP(.CRHDUIF,+CRHDEMP)
I $D(CRHDUIF) S CRHDRTN(1)=CRHDUIF
Q
DISP(CRHDRTN,CRHDEMP) ;
;COLUMNS
;DUZ^NAME^SITE^TITLE^OFFICE PH^PAGER^RM^EMAIL^SRV^MAIL CODE
N CRHDEXT,CRHDSF,CRHDPG,CRHDRM,CRHDNAM,CRHDTIT,CRHDSRV,CRHDSMC,CRHDSRM,CRHDFAX,CRHDEM
N CRHDSRVN,CRHDMC
;
K CRHDRTN
I $$GET1^DIQ(200,+CRHDEMP,.01,"I")="" Q
S CRHDNAM=$$GET1^DIQ(200,+CRHDEMP_",",.01,"E")
I $L(CRHDNAM)<2 Q
I '$$ACTIVE^XUSER(+CRHDEMP) S CRHDNAM=CRHDNAM_" (NOT AN ACTIVE USER)"
S CRHDTIT=$$GET1^DIQ(200,+CRHDEMP_",",8,"E")
S CRHDMC=$$GET1^DIQ(200,+CRHDEMP_",",28,"E") ;MAIL CODE
S CRHDEXT=$$GET1^DIQ(200,+CRHDEMP_",",.132,"E") ;OFFICE PHONE
S CRHDPG=$$GET1^DIQ(200,+CRHDEMP_",",.138,"E") ;PAGER
S CRHDEM=$$GET1^DIQ(200,+CRHDEMP_",",.151,"E") ;EMAIL ADDRESS
S CRHDRM=$$GET1^DIQ(200,+CRHDEMP_",",.141,"E") ;ROOM
S CRHDFAX=$$GET1^DIQ(200,+CRHDEMP_",",.136,"E") ;FAX
S CRHDSRV=$$GET1^DIQ(200,+CRHDEMP_",",29,"E") ;SERVICE
S CRHDSRVN=$$GET1^DIQ(200,+CRHDEMP_",",29,"I") ;SERVICE IEN
;SERVICE INFORMATION
S CRHDSMC=$$GET1^DIQ(49,+CRHDSRVN_",",1.5,"E") ;SERVICE MAIL CODE
S CRHDSRM=$$GET1^DIQ(200,+CRHDSRVN_",",6,"E") ;SERVICE LOCATION
;DISPLAY INFORMATION
S CRHDRTN=+CRHDEMP_"^"_CRHDNAM
S $P(CRHDRTN,"^",3)=$$TITLE^XLFSTR(CRHDTIT)
S $P(CRHDRTN,"^",4)=CRHDEXT
S $P(CRHDRTN,"^",5)=CRHDPG
S $P(CRHDRTN,"^",6)=CRHDRM
S $P(CRHDRTN,"^",7)=CRHDEM
S $P(CRHDRTN,"^",8)=CRHDFAX
S $P(CRHDRTN,"^",9)=CRHDSRV
S $P(CRHDRTN,"^",10)=CRHDSMC
;S $P(CRHDRTN,"^",11)=CRHDSRM
S $P(CRHDRTN,"^",11)=$TR($P($$SITE^VASITE,"^",2,3),"^","-")
Q
SRV(CRHDRTN,CRHDSRVN,CRHDDIV) ;
K CRHDRTN
N CRHDUIF,CRHDUSR,CRHDS,CRHDCT,CRHDX,CRHDSORT
I $D(^VA(200,"E")) D
.S CRHDUSR=0
.F S CRHDUSR=$O(^VA(200,"E",+CRHDSRVN,CRHDUSR)) Q:'CRHDUSR D
..I $$ACTIVE^XUSER(CRHDUSR) D
...K CRHDUIF
B ...D DISP(.CRHDUIF,CRHDUSR)
...I $D(CRHDUIF) S:$P(CRHDUIF,"^",3)'="" CRHDSORT($P(CRHDUIF,"^",2))=CRHDUIF
;COLUMNS - SEE ABOVE USER
;
;DISPLAY INFORMATION
I $D(CRHDSORT) D
.S CRHDX=""
.S CRHDCT=0
.F S CRHDX=$O(CRHDSORT(CRHDX)) Q:CRHDX="" D
..S CRHDCT=CRHDCT+1
..S CRHDRTN(CRHDCT)=CRHDSORT(CRHDX)
Q
SPEC(CRHDRTN,CRHDSP) ;
N CRHDCT,X,CRHDX,CRHDPRV,CRHDPG,CRHDNAM,CRHDS,CRHDUIF,CRHDSORT
K CRHDRTN
;S S=" "
;S CRHDRTN(1)="Specialty: "_$C(9)_$$GET1^DIQ(45.7,+CRHDSP_",",.01,"E")
;S CRHDRTN(2)=""
;S CRHDRTN(3)="No provider Found."
;S CT=2
I $D(^DIC(45.7,+CRHDSP,"PRO")) D
.S X=0
.F S X=$O(^DIC(45.7,+CRHDSP,"PRO",X)) Q:'X D
..Q:'$$ACTIVE^XUSER(X)
..S CRHDPRV=+$G(^DIC(45.7,+CRHDSP,"PRO",X,0))
..D DISP(.CRHDUIF,+CRHDPRV)
..I $D(CRHDUIF) S CRHDSORT($P(CRHDUIF,"^",2))=CRHDUIF
I $D(CRHDSORT) D
.S CRHDCT=0
.S CRHDX=""
.F S CRHDX=$O(CRHDSORT(CRHDX)) Q:CRHDX="" D
..S CRHDCT=CRHDCT+1
..S CRHDRTN(CRHDCT)=CRHDSORT(CRHDX)
Q
HOTEAM(CRHDRTN,CRHDTM) ;
;Get HOTeam phone list
N CRHDX,CRHDPRV,CRHDCT,CRHDSORT,CRHDUIF
K CRHDRTN
I '$D(^CRHD(183.3,"B",$P(CRHDTM,"^",2),+CRHDTM)) Q
S CRHDX=0
F S CRHDX=$O(^CRHD(183.3,+CRHDTM,2,CRHDX)) Q:'CRHDX D
.S CRHDPRV=+$G(^CRHD(183.3,+CRHDTM,2,CRHDX,0))
.D DISP(.CRHDUIF,+CRHDPRV)
.I $D(CRHDUIF) S CRHDSORT($P(CRHDUIF,"^",2))=CRHDUIF
I $D(CRHDSORT) D
.S CRHDCT=0
.S CRHDX=""
.F S CRHDX=$O(CRHDSORT(CRHDX)) Q:CRHDX="" D
..S CRHDCT=CRHDCT+1
..S CRHDRTN(CRHDCT)=CRHDSORT(CRHDX)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HCRHDUD 3648 printed Sep 23, 2025@20:14:26 Page 2
CRHDUD ;CAIRO/CLC - New Person general information ;04-Mar-2008 16:00;CLC;EMPLOYEE DIRECTORY
+1 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
DISPEMP(CRHDRTN,CRHDEMP) ;
+1 KILL CRHDRTN
+2 NEW CRHDUIF
+3 DO DISP(.CRHDUIF,+CRHDEMP)
+4 IF $DATA(CRHDUIF)
SET CRHDRTN(1)=CRHDUIF
+5 QUIT
DISP(CRHDRTN,CRHDEMP) ;
+1 ;COLUMNS
+2 ;DUZ^NAME^SITE^TITLE^OFFICE PH^PAGER^RM^EMAIL^SRV^MAIL CODE
+3 NEW CRHDEXT,CRHDSF,CRHDPG,CRHDRM,CRHDNAM,CRHDTIT,CRHDSRV,CRHDSMC,CRHDSRM,CRHDFAX,CRHDEM
+4 NEW CRHDSRVN,CRHDMC
+5 ;
+6 KILL CRHDRTN
+7 IF $$GET1^DIQ(200,+CRHDEMP,.01,"I")=""
QUIT
+8 SET CRHDNAM=$$GET1^DIQ(200,+CRHDEMP_",",.01,"E")
+9 IF $LENGTH(CRHDNAM)<2
QUIT
+10 IF '$$ACTIVE^XUSER(+CRHDEMP)
SET CRHDNAM=CRHDNAM_" (NOT AN ACTIVE USER)"
+11 SET CRHDTIT=$$GET1^DIQ(200,+CRHDEMP_",",8,"E")
+12 ;MAIL CODE
SET CRHDMC=$$GET1^DIQ(200,+CRHDEMP_",",28,"E")
+13 ;OFFICE PHONE
SET CRHDEXT=$$GET1^DIQ(200,+CRHDEMP_",",.132,"E")
+14 ;PAGER
SET CRHDPG=$$GET1^DIQ(200,+CRHDEMP_",",.138,"E")
+15 ;EMAIL ADDRESS
SET CRHDEM=$$GET1^DIQ(200,+CRHDEMP_",",.151,"E")
+16 ;ROOM
SET CRHDRM=$$GET1^DIQ(200,+CRHDEMP_",",.141,"E")
+17 ;FAX
SET CRHDFAX=$$GET1^DIQ(200,+CRHDEMP_",",.136,"E")
+18 ;SERVICE
SET CRHDSRV=$$GET1^DIQ(200,+CRHDEMP_",",29,"E")
+19 ;SERVICE IEN
SET CRHDSRVN=$$GET1^DIQ(200,+CRHDEMP_",",29,"I")
+20 ;SERVICE INFORMATION
+21 ;SERVICE MAIL CODE
SET CRHDSMC=$$GET1^DIQ(49,+CRHDSRVN_",",1.5,"E")
+22 ;SERVICE LOCATION
SET CRHDSRM=$$GET1^DIQ(200,+CRHDSRVN_",",6,"E")
+23 ;DISPLAY INFORMATION
+24 SET CRHDRTN=+CRHDEMP_"^"_CRHDNAM
+25 SET $PIECE(CRHDRTN,"^",3)=$$TITLE^XLFSTR(CRHDTIT)
+26 SET $PIECE(CRHDRTN,"^",4)=CRHDEXT
+27 SET $PIECE(CRHDRTN,"^",5)=CRHDPG
+28 SET $PIECE(CRHDRTN,"^",6)=CRHDRM
+29 SET $PIECE(CRHDRTN,"^",7)=CRHDEM
+30 SET $PIECE(CRHDRTN,"^",8)=CRHDFAX
+31 SET $PIECE(CRHDRTN,"^",9)=CRHDSRV
+32 SET $PIECE(CRHDRTN,"^",10)=CRHDSMC
+33 ;S $P(CRHDRTN,"^",11)=CRHDSRM
+34 SET $PIECE(CRHDRTN,"^",11)=$TRANSLATE($PIECE($$SITE^VASITE,"^",2,3),"^","-")
+35 QUIT
SRV(CRHDRTN,CRHDSRVN,CRHDDIV) ;
+1 KILL CRHDRTN
+2 NEW CRHDUIF,CRHDUSR,CRHDS,CRHDCT,CRHDX,CRHDSORT
+3 IF $DATA(^VA(200,"E"))
Begin DoDot:1
+4 SET CRHDUSR=0
+5 FOR
SET CRHDUSR=$ORDER(^VA(200,"E",+CRHDSRVN,CRHDUSR))
if 'CRHDUSR
QUIT
Begin DoDot:2
+6 IF $$ACTIVE^XUSER(CRHDUSR)
Begin DoDot:3
+7 KILL CRHDUIF
B DO DISP(.CRHDUIF,CRHDUSR)
+1 IF $DATA(CRHDUIF)
if $PIECE(CRHDUIF,"^",3)'=""
SET CRHDSORT($PIECE(CRHDUIF,"^",2))=CRHDUIF
End DoDot:3
End DoDot:2
End DoDot:1
+2 ;COLUMNS - SEE ABOVE USER
+3 ;
+4 ;DISPLAY INFORMATION
+5 IF $DATA(CRHDSORT)
Begin DoDot:1
+6 SET CRHDX=""
+7 SET CRHDCT=0
+8 FOR
SET CRHDX=$ORDER(CRHDSORT(CRHDX))
if CRHDX=""
QUIT
Begin DoDot:2
+9 SET CRHDCT=CRHDCT+1
+10 SET CRHDRTN(CRHDCT)=CRHDSORT(CRHDX)
End DoDot:2
End DoDot:1
+11 QUIT
SPEC(CRHDRTN,CRHDSP) ;
+1 NEW CRHDCT,X,CRHDX,CRHDPRV,CRHDPG,CRHDNAM,CRHDS,CRHDUIF,CRHDSORT
+2 KILL CRHDRTN
+3 ;S S=" "
+4 ;S CRHDRTN(1)="Specialty: "_$C(9)_$$GET1^DIQ(45.7,+CRHDSP_",",.01,"E")
+5 ;S CRHDRTN(2)=""
+6 ;S CRHDRTN(3)="No provider Found."
+7 ;S CT=2
+8 IF $DATA(^DIC(45.7,+CRHDSP,"PRO"))
Begin DoDot:1
+9 SET X=0
+10 FOR
SET X=$ORDER(^DIC(45.7,+CRHDSP,"PRO",X))
if 'X
QUIT
Begin DoDot:2
+11 if '$$ACTIVE^XUSER(X)
QUIT
+12 SET CRHDPRV=+$GET(^DIC(45.7,+CRHDSP,"PRO",X,0))
+13 DO DISP(.CRHDUIF,+CRHDPRV)
+14 IF $DATA(CRHDUIF)
SET CRHDSORT($PIECE(CRHDUIF,"^",2))=CRHDUIF
End DoDot:2
End DoDot:1
+15 IF $DATA(CRHDSORT)
Begin DoDot:1
+16 SET CRHDCT=0
+17 SET CRHDX=""
+18 FOR
SET CRHDX=$ORDER(CRHDSORT(CRHDX))
if CRHDX=""
QUIT
Begin DoDot:2
+19 SET CRHDCT=CRHDCT+1
+20 SET CRHDRTN(CRHDCT)=CRHDSORT(CRHDX)
End DoDot:2
End DoDot:1
+21 QUIT
HOTEAM(CRHDRTN,CRHDTM) ;
+1 ;Get HOTeam phone list
+2 NEW CRHDX,CRHDPRV,CRHDCT,CRHDSORT,CRHDUIF
+3 KILL CRHDRTN
+4 IF '$DATA(^CRHD(183.3,"B",$PIECE(CRHDTM,"^",2),+CRHDTM))
QUIT
+5 SET CRHDX=0
+6 FOR
SET CRHDX=$ORDER(^CRHD(183.3,+CRHDTM,2,CRHDX))
if 'CRHDX
QUIT
Begin DoDot:1
+7 SET CRHDPRV=+$GET(^CRHD(183.3,+CRHDTM,2,CRHDX,0))
+8 DO DISP(.CRHDUIF,+CRHDPRV)
+9 IF $DATA(CRHDUIF)
SET CRHDSORT($PIECE(CRHDUIF,"^",2))=CRHDUIF
End DoDot:1
+10 IF $DATA(CRHDSORT)
Begin DoDot:1
+11 SET CRHDCT=0
+12 SET CRHDX=""
+13 FOR
SET CRHDX=$ORDER(CRHDSORT(CRHDX))
if CRHDX=""
QUIT
Begin DoDot:2
+14 SET CRHDCT=CRHDCT+1
+15 SET CRHDRTN(CRHDCT)=CRHDSORT(CRHDX)
End DoDot:2
End DoDot:1
+16 QUIT
