- 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 Jan 18, 2025@03:39:07 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