Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: CRHDUD

CRHDUD.m

Go to the documentation of this file.
  1. CRHDUD ;CAIRO/CLC - New Person general information ;04-Mar-2008 16:00;CLC;EMPLOYEE DIRECTORY
  1. ;;1.0;CRHD;****;Jan 28, 2008;Build 19
  1. DISPEMP(CRHDRTN,CRHDEMP) ;
  1. K CRHDRTN
  1. N CRHDUIF
  1. D DISP(.CRHDUIF,+CRHDEMP)
  1. I $D(CRHDUIF) S CRHDRTN(1)=CRHDUIF
  1. Q
  1. DISP(CRHDRTN,CRHDEMP) ;
  1. ;COLUMNS
  1. ;DUZ^NAME^SITE^TITLE^OFFICE PH^PAGER^RM^EMAIL^SRV^MAIL CODE
  1. N CRHDEXT,CRHDSF,CRHDPG,CRHDRM,CRHDNAM,CRHDTIT,CRHDSRV,CRHDSMC,CRHDSRM,CRHDFAX,CRHDEM
  1. N CRHDSRVN,CRHDMC
  1. ;
  1. K CRHDRTN
  1. I $$GET1^DIQ(200,+CRHDEMP,.01,"I")="" Q
  1. S CRHDNAM=$$GET1^DIQ(200,+CRHDEMP_",",.01,"E")
  1. I $L(CRHDNAM)<2 Q
  1. I '$$ACTIVE^XUSER(+CRHDEMP) S CRHDNAM=CRHDNAM_" (NOT AN ACTIVE USER)"
  1. S CRHDTIT=$$GET1^DIQ(200,+CRHDEMP_",",8,"E")
  1. S CRHDMC=$$GET1^DIQ(200,+CRHDEMP_",",28,"E") ;MAIL CODE
  1. S CRHDEXT=$$GET1^DIQ(200,+CRHDEMP_",",.132,"E") ;OFFICE PHONE
  1. S CRHDPG=$$GET1^DIQ(200,+CRHDEMP_",",.138,"E") ;PAGER
  1. S CRHDEM=$$GET1^DIQ(200,+CRHDEMP_",",.151,"E") ;EMAIL ADDRESS
  1. S CRHDRM=$$GET1^DIQ(200,+CRHDEMP_",",.141,"E") ;ROOM
  1. S CRHDFAX=$$GET1^DIQ(200,+CRHDEMP_",",.136,"E") ;FAX
  1. S CRHDSRV=$$GET1^DIQ(200,+CRHDEMP_",",29,"E") ;SERVICE
  1. S CRHDSRVN=$$GET1^DIQ(200,+CRHDEMP_",",29,"I") ;SERVICE IEN
  1. ;SERVICE INFORMATION
  1. S CRHDSMC=$$GET1^DIQ(49,+CRHDSRVN_",",1.5,"E") ;SERVICE MAIL CODE
  1. S CRHDSRM=$$GET1^DIQ(200,+CRHDSRVN_",",6,"E") ;SERVICE LOCATION
  1. ;DISPLAY INFORMATION
  1. S CRHDRTN=+CRHDEMP_"^"_CRHDNAM
  1. S $P(CRHDRTN,"^",3)=$$TITLE^XLFSTR(CRHDTIT)
  1. S $P(CRHDRTN,"^",4)=CRHDEXT
  1. S $P(CRHDRTN,"^",5)=CRHDPG
  1. S $P(CRHDRTN,"^",6)=CRHDRM
  1. S $P(CRHDRTN,"^",7)=CRHDEM
  1. S $P(CRHDRTN,"^",8)=CRHDFAX
  1. S $P(CRHDRTN,"^",9)=CRHDSRV
  1. S $P(CRHDRTN,"^",10)=CRHDSMC
  1. ;S $P(CRHDRTN,"^",11)=CRHDSRM
  1. S $P(CRHDRTN,"^",11)=$TR($P($$SITE^VASITE,"^",2,3),"^","-")
  1. Q
  1. SRV(CRHDRTN,CRHDSRVN,CRHDDIV) ;
  1. K CRHDRTN
  1. N CRHDUIF,CRHDUSR,CRHDS,CRHDCT,CRHDX,CRHDSORT
  1. I $D(^VA(200,"E")) D
  1. .S CRHDUSR=0
  1. .F S CRHDUSR=$O(^VA(200,"E",+CRHDSRVN,CRHDUSR)) Q:'CRHDUSR D
  1. ..I $$ACTIVE^XUSER(CRHDUSR) D
  1. ...K CRHDUIF
  1. B ...D DISP(.CRHDUIF,CRHDUSR)
  1. ...I $D(CRHDUIF) S:$P(CRHDUIF,"^",3)'="" CRHDSORT($P(CRHDUIF,"^",2))=CRHDUIF
  1. ;COLUMNS - SEE ABOVE USER
  1. ;
  1. ;DISPLAY INFORMATION
  1. I $D(CRHDSORT) D
  1. .S CRHDX=""
  1. .S CRHDCT=0
  1. .F S CRHDX=$O(CRHDSORT(CRHDX)) Q:CRHDX="" D
  1. ..S CRHDCT=CRHDCT+1
  1. ..S CRHDRTN(CRHDCT)=CRHDSORT(CRHDX)
  1. Q
  1. SPEC(CRHDRTN,CRHDSP) ;
  1. N CRHDCT,X,CRHDX,CRHDPRV,CRHDPG,CRHDNAM,CRHDS,CRHDUIF,CRHDSORT
  1. K CRHDRTN
  1. ;S S=" "
  1. ;S CRHDRTN(1)="Specialty: "_$C(9)_$$GET1^DIQ(45.7,+CRHDSP_",",.01,"E")
  1. ;S CRHDRTN(2)=""
  1. ;S CRHDRTN(3)="No provider Found."
  1. ;S CT=2
  1. I $D(^DIC(45.7,+CRHDSP,"PRO")) D
  1. .S X=0
  1. .F S X=$O(^DIC(45.7,+CRHDSP,"PRO",X)) Q:'X D
  1. ..Q:'$$ACTIVE^XUSER(X)
  1. ..S CRHDPRV=+$G(^DIC(45.7,+CRHDSP,"PRO",X,0))
  1. ..D DISP(.CRHDUIF,+CRHDPRV)
  1. ..I $D(CRHDUIF) S CRHDSORT($P(CRHDUIF,"^",2))=CRHDUIF
  1. I $D(CRHDSORT) D
  1. .S CRHDCT=0
  1. .S CRHDX=""
  1. .F S CRHDX=$O(CRHDSORT(CRHDX)) Q:CRHDX="" D
  1. ..S CRHDCT=CRHDCT+1
  1. ..S CRHDRTN(CRHDCT)=CRHDSORT(CRHDX)
  1. Q
  1. HOTEAM(CRHDRTN,CRHDTM) ;
  1. ;Get HOTeam phone list
  1. N CRHDX,CRHDPRV,CRHDCT,CRHDSORT,CRHDUIF
  1. K CRHDRTN
  1. I '$D(^CRHD(183.3,"B",$P(CRHDTM,"^",2),+CRHDTM)) Q
  1. S CRHDX=0
  1. F S CRHDX=$O(^CRHD(183.3,+CRHDTM,2,CRHDX)) Q:'CRHDX D
  1. .S CRHDPRV=+$G(^CRHD(183.3,+CRHDTM,2,CRHDX,0))
  1. .D DISP(.CRHDUIF,+CRHDPRV)
  1. .I $D(CRHDUIF) S CRHDSORT($P(CRHDUIF,"^",2))=CRHDUIF
  1. I $D(CRHDSORT) D
  1. .S CRHDCT=0
  1. .S CRHDX=""
  1. .F S CRHDX=$O(CRHDSORT(CRHDX)) Q:CRHDX="" D
  1. ..S CRHDCT=CRHDCT+1
  1. ..S CRHDRTN(CRHDCT)=CRHDSORT(CRHDX)
  1. Q