EDPQDBS ;SLC/KCM - Display Board Specs ;5/23/13 11:10am
;;2.0;EMERGENCY DEPARTMENT;**6**;Feb 24, 2012;Build 200
;
GET(AREA,BOARD) ; Get Display Board Specs
;N I S I=0
;F S I=$O(^EDPB(231.9,AREA,2,I)) Q:'I D XML^EDPX(^EDPB(231.9,AREA,2,I,0))
N ROLEIEN,R0,RNAME,RABBR,RXML
I '$L($G(BOARD)) S BOARD="Main (default)"
S BOARD=$O(^EDPB(231.9,AREA,4,"B",BOARD,0))
D LOADBRD^EDPBCF(AREA,BOARD)
;
D XML^EDPX("<colorSpec>")
D CLRBED(AREA)
; bwf 5/23/2013 - if the CPE ROLE file has no entries, use old logic
I '$O(^EDPB(232.5,0)) D
.D CLRSTAFF(AREA,"md","P")
.D CLRSTAFF(AREA,"res","R")
.D CLRSTAFF(AREA,"rn","N")
; end changes bwf
;D CLRSTAFF(AREA,"md","P")
;D CLRSTAFF(AREA,"res","R")
;D CLRSTAFF(AREA,"rn","N")
; bwf 5/23/2013
I $O(^EDPB(232.5,0)) D
.S ROLEIEN=0 F S ROLEIEN=$O(^EDPB(232.5,ROLEIEN)) Q:'ROLEIEN D
..S R0=$G(^EDPB(232.5,ROLEIEN,0)),RNAME=$P(R0,U),RABBR=$P(R0,U,2),RXML=$P(R0,U,3)
..D CLRSTAF2(AREA,RXML,ROLEIEN)
; end changes bwf
; BWF - REPLACED BELOW CODE WITH CODE ABOVE 5/23/2013
;S ROLEIEN=0 F S ROLEIEN=$O(^EDPB(232.5,ROLEIEN)) Q:'ROLEIEN D
;.S R0=$G(^EDPB(232.5,ROLEIEN,0)),RNAME=$P(R0,U),RABBR=$P(R0,U,2),RXML=$P(R0,U,3)
;.D CLRSTAFF(AREA,RXML,ROLEIEN)
N I S I=0
F S I=$O(^EDPB(231.9,AREA,3,I)) Q:'I D XML^EDPX(^EDPB(231.9,AREA,3,I,0))
D XML^EDPX("</colorSpec>")
Q
CLRBED(AREA) ; add bed colors
D XML^EDPX("<colors id='bed' type='bed' >")
N BED,X0
S BED=0 F S BED=$O(^EDPB(231.8,"C",EDPSITE,AREA,BED)) Q:'BED D
. S X0=^EDPB(231.8,BED,0)
. I $P(X0,U,12)="" Q
. N X
. S X("att")="@bed"
. S X("clr")=$P(X0,U,12)
. S X("val")=BED
. D XML^EDPX($$XMLA^EDPX("map",.X))
D XML^EDPX("</colors>")
Q
CLRSTAFF(AREA,ROLEID,ROLE) ; add staff colors
D XML^EDPX("<colors id='"_ROLEID_"' type='staff' >")
N IEN
S IEN="" F S IEN=$O(^EDPB(231.7,"AC",EDPSITE,AREA,ROLE,IEN)) Q:'IEN D
. S X0=^EDPB(231.7,IEN,0) Q:'$P(X0,U,8)
. N X
. S X("att")=$S(ROLE="P":"@md",ROLE="N":"@rn",ROLE="R":"@res",1:"nop")
. S X("clr")=$P(X0,U,8)
. S X("val")=$P(X0,U)
. D XML^EDPX($$XMLA^EDPX("map",.X))
D XML^EDPX("</colors>")
Q
; BWF 5/23/2013 - Added new module for backward compatibility
CLRSTAF2(AREA,ROLEID,ROLEIEN) ; add staff colors
D XML^EDPX("<colors id='"_$P(ROLEID,"@",2)_"' type='staff' >")
N IEN
S IEN="" F S IEN=$O(^EDPB(231.7,"AC",EDPSITE,AREA,ROLEIEN,IEN)) Q:'IEN D
. S X0=^EDPB(231.7,IEN,0) Q:'$P(X0,U,8)
. N X
. S X("att")=$S(ROLEID'="":ROLEID,1:"nop")
. ;S X("att")=$S(ROLE="P":"@md",ROLE="N":"@rn",ROLE="R":"@res",1:"nop")
. S X("clr")=$P(X0,U,8)
. S X("val")=$P(X0,U)
. D XML^EDPX($$XMLA^EDPX("map",.X))
D XML^EDPX("</colors>")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEDPQDBS 2685 printed Apr 09, 2024@20:57:34 Page 2
EDPQDBS ;SLC/KCM - Display Board Specs ;5/23/13 11:10am
+1 ;;2.0;EMERGENCY DEPARTMENT;**6**;Feb 24, 2012;Build 200
+2 ;
GET(AREA,BOARD) ; Get Display Board Specs
+1 ;N I S I=0
+2 ;F S I=$O(^EDPB(231.9,AREA,2,I)) Q:'I D XML^EDPX(^EDPB(231.9,AREA,2,I,0))
+3 NEW ROLEIEN,R0,RNAME,RABBR,RXML
+4 IF '$LENGTH($GET(BOARD))
SET BOARD="Main (default)"
+5 SET BOARD=$ORDER(^EDPB(231.9,AREA,4,"B",BOARD,0))
+6 DO LOADBRD^EDPBCF(AREA,BOARD)
+7 ;
+8 DO XML^EDPX("<colorSpec>")
+9 DO CLRBED(AREA)
+10 ; bwf 5/23/2013 - if the CPE ROLE file has no entries, use old logic
+11 IF '$ORDER(^EDPB(232.5,0))
Begin DoDot:1
+12 DO CLRSTAFF(AREA,"md","P")
+13 DO CLRSTAFF(AREA,"res","R")
+14 DO CLRSTAFF(AREA,"rn","N")
End DoDot:1
+15 ; end changes bwf
+16 ;D CLRSTAFF(AREA,"md","P")
+17 ;D CLRSTAFF(AREA,"res","R")
+18 ;D CLRSTAFF(AREA,"rn","N")
+19 ; bwf 5/23/2013
+20 IF $ORDER(^EDPB(232.5,0))
Begin DoDot:1
+21 SET ROLEIEN=0
FOR
SET ROLEIEN=$ORDER(^EDPB(232.5,ROLEIEN))
if 'ROLEIEN
QUIT
Begin DoDot:2
+22 SET R0=$GET(^EDPB(232.5,ROLEIEN,0))
SET RNAME=$PIECE(R0,U)
SET RABBR=$PIECE(R0,U,2)
SET RXML=$PIECE(R0,U,3)
+23 DO CLRSTAF2(AREA,RXML,ROLEIEN)
End DoDot:2
End DoDot:1
+24 ; end changes bwf
+25 ; BWF - REPLACED BELOW CODE WITH CODE ABOVE 5/23/2013
+26 ;S ROLEIEN=0 F S ROLEIEN=$O(^EDPB(232.5,ROLEIEN)) Q:'ROLEIEN D
+27 ;.S R0=$G(^EDPB(232.5,ROLEIEN,0)),RNAME=$P(R0,U),RABBR=$P(R0,U,2),RXML=$P(R0,U,3)
+28 ;.D CLRSTAFF(AREA,RXML,ROLEIEN)
+29 NEW I
SET I=0
+30 FOR
SET I=$ORDER(^EDPB(231.9,AREA,3,I))
if 'I
QUIT
DO XML^EDPX(^EDPB(231.9,AREA,3,I,0))
+31 DO XML^EDPX("</colorSpec>")
+32 QUIT
CLRBED(AREA) ; add bed colors
+1 DO XML^EDPX("<colors id='bed' type='bed' >")
+2 NEW BED,X0
+3 SET BED=0
FOR
SET BED=$ORDER(^EDPB(231.8,"C",EDPSITE,AREA,BED))
if 'BED
QUIT
Begin DoDot:1
+4 SET X0=^EDPB(231.8,BED,0)
+5 IF $PIECE(X0,U,12)=""
QUIT
+6 NEW X
+7 SET X("att")="@bed"
+8 SET X("clr")=$PIECE(X0,U,12)
+9 SET X("val")=BED
+10 DO XML^EDPX($$XMLA^EDPX("map",.X))
End DoDot:1
+11 DO XML^EDPX("</colors>")
+12 QUIT
CLRSTAFF(AREA,ROLEID,ROLE) ; add staff colors
+1 DO XML^EDPX("<colors id='"_ROLEID_"' type='staff' >")
+2 NEW IEN
+3 SET IEN=""
FOR
SET IEN=$ORDER(^EDPB(231.7,"AC",EDPSITE,AREA,ROLE,IEN))
if 'IEN
QUIT
Begin DoDot:1
+4 SET X0=^EDPB(231.7,IEN,0)
if '$PIECE(X0,U,8)
QUIT
+5 NEW X
+6 SET X("att")=$SELECT(ROLE="P":"@md",ROLE="N":"@rn",ROLE="R":"@res",1:"nop")
+7 SET X("clr")=$PIECE(X0,U,8)
+8 SET X("val")=$PIECE(X0,U)
+9 DO XML^EDPX($$XMLA^EDPX("map",.X))
End DoDot:1
+10 DO XML^EDPX("</colors>")
+11 QUIT
+12 ; BWF 5/23/2013 - Added new module for backward compatibility
CLRSTAF2(AREA,ROLEID,ROLEIEN) ; add staff colors
+1 DO XML^EDPX("<colors id='"_$PIECE(ROLEID,"@",2)_"' type='staff' >")
+2 NEW IEN
+3 SET IEN=""
FOR
SET IEN=$ORDER(^EDPB(231.7,"AC",EDPSITE,AREA,ROLEIEN,IEN))
if 'IEN
QUIT
Begin DoDot:1
+4 SET X0=^EDPB(231.7,IEN,0)
if '$PIECE(X0,U,8)
QUIT
+5 NEW X
+6 SET X("att")=$SELECT(ROLEID'="":ROLEID,1:"nop")
+7 ;S X("att")=$S(ROLE="P":"@md",ROLE="N":"@rn",ROLE="R":"@res",1:"nop")
+8 SET X("clr")=$PIECE(X0,U,8)
+9 SET X("val")=$PIECE(X0,U)
+10 DO XML^EDPX($$XMLA^EDPX("map",.X))
End DoDot:1
+11 DO XML^EDPX("</colors>")
+12 QUIT
