EDPBSL ;SLC/KCM - Selection List Configuration ;2/28/12 08:33am
;;2.0;EMERGENCY DEPARTMENT;;May 2, 2012;Build 103
;
LOAD(AREA) ; Load selection lists for area
N TOKEN
D READL^EDPBLK(AREA,"selection",.TOKEN) ; read selection config -- LOCK
D XML^EDPX("<selectionToken>"_TOKEN_"</selectionToken>")
;D LIST("acuity","Acuity")
D LIST("status","Status")
D LIST("arrival","Source")
D LIST("disposition","Disposition")
D LIST("delay","Delay Reason")
D READU^EDPBLK(AREA,"selection",.TOKEN) ; read selection config -- UNLOCK
Q
LIST(NM,TITLE) ; build XML for selection list
N SETNM S SETNM=EDPSTA_"."_NM
I '$D(^EDPB(233.2,"B",SETNM)) S SETNM="edp."_NM
D XML^EDPX("<"_NM_" title='"_TITLE_"'>")
N IEN,SEQ,DA,X0
S IEN=$O(^EDPB(233.2,"B",SETNM,0))
S SEQ=0 F S SEQ=$O(^EDPB(233.2,IEN,1,"B",SEQ)) Q:'SEQ D
. S DA=0 F S DA=$O(^EDPB(233.2,IEN,1,"B",SEQ,DA)) Q:'DA D
. . S X0=^EDPB(233.2,IEN,1,DA,0)
. . N X
. . S X("seq")=SEQ
. . S X("id")=$P(X0,U,2)
. . S X("inact")=$P(X0,U,3)
. . S X("show")=$P(X0,U,4)
. . S X("abbr")=$P(X0,U,5)
. . ; switch to entry in 233.1 now
. . S X0=^EDPB(233.1,X("id"),0)
. . I X("show")="" S X("show")=$P(X0,U,2)
. . I X("abbr")="" S X("abbr")=$P(X0,U,3)
. . S X("flag")=$P(X0,U,5)
. . S X("natl")=$S($E(X0,1,3)="edp":$P(X0,U,2),1:"(local)")
. . D XML^EDPX($$XMLA^EDPX("code",.X))
D XML^EDPX("</"_NM_">")
Q
SAVE(EDPAREA,REQ) ; save the selection changes
N CTYP,SET,SETNM,CODE,X,EDPERR,TOKEN,LOCKERR
;
S TOKEN=$G(REQ("selectionToken",1))
D SAVEL^EDPBLK(EDPAREA,"selection",.TOKEN,.LOCKERR) ; save selection config -- LOCK
I $L(LOCKERR) D SAVERR^EDPX("collide",LOCKERR),LOAD(EDPAREA) Q
;
S EDPERR=""
F CTYP="status","disposition","delay","arrival" D
. I $E($O(REQ(CTYP)),1,$L(CTYP))'=CTYP Q
. S SETNM=EDPSTA_"."_CTYP,SET=$O(^EDPB(233.2,"B",SETNM,0))
. I 'SET D NEWSET(SETNM) S SET=$O(^EDPB(233.2,"B",SETNM,0))
. D CLEARSET(SET)
. S X=CTYP F S X=$O(REQ(X)) Q:$E(X,1,$L(CTYP))'=CTYP D
. . K CODE S CODE="" D NVPARSE^EDPX(.CODE,REQ(X,1))
. . ; I CODE("id")>0 D UPDCODE(CTYP,.CODE) -- want to keep codes matched to nat'l --KCM
. . I CODE("id")<1 D ADDCODE(CTYP,.CODE)
. . D ADD2SET(SET,.CODE)
D SAVEU^EDPBLK(EDPAREA,"selection",.TOKEN) ; save selection config -- UNLOCK
;
I $L(EDPERR) D SAVERR^EDPX("fail",EDPERR) Q
D XML^EDPX("<save status='ok' />")
D LOAD(EDPAREA)
S ^EDPB(231.9,EDPAREA,231)=$H ; update choices timestamp
Q
NEWSET(SETNM) ; Create a new code set for a site
N FDA,FDAIEN,DIERR,ERR
S FDA(233.2,"+1,",.01)=SETNM
D UPDATE^DIE("","FDA","FDAIEN","ERR")
I $D(DIERR) S EDPERR=EDPERR_"new code set failed;"
Q
CLEARSET(SET) ; Clear the CODES mulitple
I '$O(^EDPB(233.2,SET,1,0)) Q ; no child nodes
N DA,DIK S DA=0,DA(1)=SET,DIK="^EDPB(233.2,"_DA(1)_",1,"
F S DA=$O(^EDPB(233.2,SET,1,DA)) Q:'DA D ^DIK
Q
UPDCODE(CTYP,X) ; Update an existing code in the TRACKING CODE file
Q:+$G(X("id"))'>0
N OLD,DIFF,I
S OLD=$G(^EDPB(233.1,+$G(X("id")),0)),DIFF=0
F I="2^show","3^abbr","5^flag" I $P(OLD,U,+I)'=$G(X($P(I,U,2))) S DIFF=1 Q
Q:'DIFF ;no change
I $E(OLD,1,4)="edp." S X("id")=0 D ADDCODE(CTYP,.X) Q
; update local code
N FDA,FDAIEN,DIERR,ERR
S FDAIEN=+X("id")_","
S FDA(233.1,FDAIEN,.02)=X("show")
S FDA(233.1,FDAIEN,.03)=X("abbr")
S FDA(233.1,FDAIEN,.05)=X("flag")
D FILE^DIE("","FDA","ERR")
I $D(DIERR) S EDPERR=EDPERR_"update code "_NAME_"failed;"
S X("nm")=$P(OLD,U)
Q
ADDCODE(CTYP,X) ; Add a new code to the TRACKING CODE file
Q:X("id")'=0
N NAME,DNAME,I
S NAME=EDPSTA_"."_CTYP_"."_$TR(X("show")," ","")
I $O(^EDPB(233.1,"B",NAME,0)) D
. F I=1:1:99 Q:'$O(^EDPB(233.1,"B",NAME_I,0))
. S NAME=NAME_I
N FDA,FDAIEN,DIERR,ERR
S FDA(233.1,"+1,",.01)=NAME
S FDA(233.1,"+1,",.02)=X("show")
S FDA(233.1,"+1,",.03)=X("abbr")
S FDA(233.1,"+1,",.05)=X("flag")
D UPDATE^DIE("","FDA","FDAIEN","ERR")
I $D(DIERR) S EDPERR=EDPERR_"add code "_NAME_"failed;"
S X("id")=FDAIEN(1),X("nm")=NAME
Q
ADD2SET(SET,X) ; Add a new code to the CODES multiple
N FDA,FDAIEN,DIERR,ERR
S FDA(233.21,"+1,"_SET_",",.01)=X("seq")
S FDA(233.21,"+1,"_SET_",",.02)=X("id")
S FDA(233.21,"+1,"_SET_",",.03)=X("inact")
S FDA(233.21,"+1,"_SET_",",.04)=X("show")
S FDA(233.21,"+1,"_SET_",",.05)=X("abbr")
D UPDATE^DIE("","FDA","FDAIEN","ERR")
I $D(DIERR) S EDPERR=EDPERR_"add to set "_X("show")_" failed;"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEDPBSL 4426 printed Apr 09, 2024@20:57:23 Page 2
EDPBSL ;SLC/KCM - Selection List Configuration ;2/28/12 08:33am
+1 ;;2.0;EMERGENCY DEPARTMENT;;May 2, 2012;Build 103
+2 ;
LOAD(AREA) ; Load selection lists for area
+1 NEW TOKEN
+2 ; read selection config -- LOCK
DO READL^EDPBLK(AREA,"selection",.TOKEN)
+3 DO XML^EDPX("<selectionToken>"_TOKEN_"</selectionToken>")
+4 ;D LIST("acuity","Acuity")
+5 DO LIST("status","Status")
+6 DO LIST("arrival","Source")
+7 DO LIST("disposition","Disposition")
+8 DO LIST("delay","Delay Reason")
+9 ; read selection config -- UNLOCK
DO READU^EDPBLK(AREA,"selection",.TOKEN)
+10 QUIT
LIST(NM,TITLE) ; build XML for selection list
+1 NEW SETNM
SET SETNM=EDPSTA_"."_NM
+2 IF '$DATA(^EDPB(233.2,"B",SETNM))
SET SETNM="edp."_NM
+3 DO XML^EDPX("<"_NM_" title='"_TITLE_"'>")
+4 NEW IEN,SEQ,DA,X0
+5 SET IEN=$ORDER(^EDPB(233.2,"B",SETNM,0))
+6 SET SEQ=0
FOR
SET SEQ=$ORDER(^EDPB(233.2,IEN,1,"B",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+7 SET DA=0
FOR
SET DA=$ORDER(^EDPB(233.2,IEN,1,"B",SEQ,DA))
if 'DA
QUIT
Begin DoDot:2
+8 SET X0=^EDPB(233.2,IEN,1,DA,0)
+9 NEW X
+10 SET X("seq")=SEQ
+11 SET X("id")=$PIECE(X0,U,2)
+12 SET X("inact")=$PIECE(X0,U,3)
+13 SET X("show")=$PIECE(X0,U,4)
+14 SET X("abbr")=$PIECE(X0,U,5)
+15 ; switch to entry in 233.1 now
+16 SET X0=^EDPB(233.1,X("id"),0)
+17 IF X("show")=""
SET X("show")=$PIECE(X0,U,2)
+18 IF X("abbr")=""
SET X("abbr")=$PIECE(X0,U,3)
+19 SET X("flag")=$PIECE(X0,U,5)
+20 SET X("natl")=$SELECT($EXTRACT(X0,1,3)="edp":$PIECE(X0,U,2),1:"(local)")
+21 DO XML^EDPX($$XMLA^EDPX("code",.X))
End DoDot:2
End DoDot:1
+22 DO XML^EDPX("</"_NM_">")
+23 QUIT
SAVE(EDPAREA,REQ) ; save the selection changes
+1 NEW CTYP,SET,SETNM,CODE,X,EDPERR,TOKEN,LOCKERR
+2 ;
+3 SET TOKEN=$GET(REQ("selectionToken",1))
+4 ; save selection config -- LOCK
DO SAVEL^EDPBLK(EDPAREA,"selection",.TOKEN,.LOCKERR)
+5 IF $LENGTH(LOCKERR)
DO SAVERR^EDPX("collide",LOCKERR)
DO LOAD(EDPAREA)
QUIT
+6 ;
+7 SET EDPERR=""
+8 FOR CTYP="status","disposition","delay","arrival"
Begin DoDot:1
+9 IF $EXTRACT($ORDER(REQ(CTYP)),1,$LENGTH(CTYP))'=CTYP
QUIT
+10 SET SETNM=EDPSTA_"."_CTYP
SET SET=$ORDER(^EDPB(233.2,"B",SETNM,0))
+11 IF 'SET
DO NEWSET(SETNM)
SET SET=$ORDER(^EDPB(233.2,"B",SETNM,0))
+12 DO CLEARSET(SET)
+13 SET X=CTYP
FOR
SET X=$ORDER(REQ(X))
if $EXTRACT(X,1,$LENGTH(CTYP))'=CTYP
QUIT
Begin DoDot:2
+14 KILL CODE
SET CODE=""
DO NVPARSE^EDPX(.CODE,REQ(X,1))
+15 ; I CODE("id")>0 D UPDCODE(CTYP,.CODE) -- want to keep codes matched to nat'l --KCM
+16 IF CODE("id")<1
DO ADDCODE(CTYP,.CODE)
+17 DO ADD2SET(SET,.CODE)
End DoDot:2
End DoDot:1
+18 ; save selection config -- UNLOCK
DO SAVEU^EDPBLK(EDPAREA,"selection",.TOKEN)
+19 ;
+20 IF $LENGTH(EDPERR)
DO SAVERR^EDPX("fail",EDPERR)
QUIT
+21 DO XML^EDPX("<save status='ok' />")
+22 DO LOAD(EDPAREA)
+23 ; update choices timestamp
SET ^EDPB(231.9,EDPAREA,231)=$HOROLOG
+24 QUIT
NEWSET(SETNM) ; Create a new code set for a site
+1 NEW FDA,FDAIEN,DIERR,ERR
+2 SET FDA(233.2,"+1,",.01)=SETNM
+3 DO UPDATE^DIE("","FDA","FDAIEN","ERR")
+4 IF $DATA(DIERR)
SET EDPERR=EDPERR_"new code set failed;"
+5 QUIT
CLEARSET(SET) ; Clear the CODES mulitple
+1 ; no child nodes
IF '$ORDER(^EDPB(233.2,SET,1,0))
QUIT
+2 NEW DA,DIK
SET DA=0
SET DA(1)=SET
SET DIK="^EDPB(233.2,"_DA(1)_",1,"
+3 FOR
SET DA=$ORDER(^EDPB(233.2,SET,1,DA))
if 'DA
QUIT
DO ^DIK
+4 QUIT
UPDCODE(CTYP,X) ; Update an existing code in the TRACKING CODE file
+1 if +$GET(X("id"))'>0
QUIT
+2 NEW OLD,DIFF,I
+3 SET OLD=$GET(^EDPB(233.1,+$GET(X("id")),0))
SET DIFF=0
+4 FOR I="2^show","3^abbr","5^flag"
IF $PIECE(OLD,U,+I)'=$GET(X($PIECE(I,U,2)))
SET DIFF=1
QUIT
+5 ;no change
if 'DIFF
QUIT
+6 IF $EXTRACT(OLD,1,4)="edp."
SET X("id")=0
DO ADDCODE(CTYP,.X)
QUIT
+7 ; update local code
+8 NEW FDA,FDAIEN,DIERR,ERR
+9 SET FDAIEN=+X("id")_","
+10 SET FDA(233.1,FDAIEN,.02)=X("show")
+11 SET FDA(233.1,FDAIEN,.03)=X("abbr")
+12 SET FDA(233.1,FDAIEN,.05)=X("flag")
+13 DO FILE^DIE("","FDA","ERR")
+14 IF $DATA(DIERR)
SET EDPERR=EDPERR_"update code "_NAME_"failed;"
+15 SET X("nm")=$PIECE(OLD,U)
+16 QUIT
ADDCODE(CTYP,X) ; Add a new code to the TRACKING CODE file
+1 if X("id")'=0
QUIT
+2 NEW NAME,DNAME,I
+3 SET NAME=EDPSTA_"."_CTYP_"."_$TRANSLATE(X("show")," ","")
+4 IF $ORDER(^EDPB(233.1,"B",NAME,0))
Begin DoDot:1
+5 FOR I=1:1:99
if '$ORDER(^EDPB(233.1,"B",NAME_I,0))
QUIT
+6 SET NAME=NAME_I
End DoDot:1
+7 NEW FDA,FDAIEN,DIERR,ERR
+8 SET FDA(233.1,"+1,",.01)=NAME
+9 SET FDA(233.1,"+1,",.02)=X("show")
+10 SET FDA(233.1,"+1,",.03)=X("abbr")
+11 SET FDA(233.1,"+1,",.05)=X("flag")
+12 DO UPDATE^DIE("","FDA","FDAIEN","ERR")
+13 IF $DATA(DIERR)
SET EDPERR=EDPERR_"add code "_NAME_"failed;"
+14 SET X("id")=FDAIEN(1)
SET X("nm")=NAME
+15 QUIT
ADD2SET(SET,X) ; Add a new code to the CODES multiple
+1 NEW FDA,FDAIEN,DIERR,ERR
+2 SET FDA(233.21,"+1,"_SET_",",.01)=X("seq")
+3 SET FDA(233.21,"+1,"_SET_",",.02)=X("id")
+4 SET FDA(233.21,"+1,"_SET_",",.03)=X("inact")
+5 SET FDA(233.21,"+1,"_SET_",",.04)=X("show")
+6 SET FDA(233.21,"+1,"_SET_",",.05)=X("abbr")
+7 DO UPDATE^DIE("","FDA","FDAIEN","ERR")
+8 IF $DATA(DIERR)
SET EDPERR=EDPERR_"add to set "_X("show")_" failed;"
+9 QUIT
