IBDF9A1 ;ALB/CJM - ENCOUNTER FORM - (create,edit,delete selection list - continued) ;FEB 1,1993
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
NEWLIST ;creates a new list
;expects IBBLK to be defined
N IBLIST,IBLEN,IBP,IBRTN,NAME,IBDELETE,IBDYN,IBINPUT,IBDFLTF,IBDFLTB,IBDFLTL
S (IBDFLTF,IBDFLTB,IBDFLTL,IBOLD,IBLIST)=0,VALMBCK="R"
D FULL^VALM1
S IBRTN=$$RTN^IBDF9A Q:'IBRTN
S IBDFLTF=$$DFLTS^IBDFU5 D:IBDFLTF
.S IBDFLTB=0 F S IBDFLTB=$O(^IBE(357.1,"C",IBDFLTF,IBDFLTB)) Q:'IBDFLTB D Q:IBDFLTL
..S IBDFLTL=0 F S IBDFLTL=$O(^IBE(357.2,"C",IBDFLTB,IBDFLTL)) Q:'IBDFLTL Q:$P($G(^IBE(357.2,IBDFLTL,0)),"^",11)=IBRTN
I IBDFLTL D Q:IBLIST
.S IBLIST=$$COPYLIST^IBDFU2(IBDFLTL,IBDFLTB,IBBLK,357.2,357.2)
.Q:'IBLIST
.K DIE,DA,DR S DIE=357.2,DA=IBLIST,DR="[IBDF POSITION/SIZE COLUMNS]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
.S VALMBCK="R" D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
S NAME=$$NEWNAME^IBDF9A Q:NAME=-1
K DIC,DIE,DD,DO,DINUM,DA
N DLAYGO
S DIC="^IBE(357.2,",DIC(0)="FL",X=NAME,DLAYGO=357.2
D FILE^DICN K DIC,DA
S IBLIST=$S(+Y<0:"",1:+Y)
I 'IBLIST D
.W !,"Unable to create a new selection list!" D PAUSE^IBDFU5
I IBLIST D
.D DLISTCNT^IBDFU3(IBLIST,357.2) ;deletes anything that may have been left lying around that now points to IBLIST
.K DIE,DA,DR S DIE=357.2,DA=IBLIST,DR="[IBDF EDIT SELECTION LIST]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
.I IBDELETE K DA S DIK="^IBE(357.2,",DA=IBLIST D ^DIK K DIK,DA
.I IBLIST,'IBDELETE D ADDGROUP("BLANK",0)
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
S VALMBCK="R"
Q
ADDGROUP(NAME,ORDER) ;adds a group to the selection list=IBLIST
N GROUP
K DIC,DIE,DD,DO,DINUM,DA
N DLAYGO
S DIC="^IBE(357.4,",DIC(0)="FL",X=NAME,DLAYGO=357.4
D FILE^DICN K DIC,DA
S GROUP=$S(+Y<0:"",1:+Y)
I GROUP D
.S NODE=$G(^IBE(357.4,GROUP,0)) S $P(NODE,"^",2)=ORDER,$P(NODE,"^",3)=IBLIST S ^IBE(357.4,GROUP,0)=NODE
.S DIK="^IBE(357.4,",DA=GROUP D IX1^DIK K DIK,DA
Q
;
FORMAT ;allows the user to format all of the selections on the list in mass
;
;
;TYPE = type of formating - U=upper case,L=lower case,C=capitalize
;SUBCOL is the subcolumn to format
;
N TYPE,SUBCOL,SLCTN
;
;ask for the subcolumn to format
S SUBCOL=$$SUBCOL
;
;ask for the type of fomatting
S TYPE=$S(SUBCOL:$$TYPE,1:"")
;
;find all the sections to be formatted and do so
I TYPE'="",SUBCOL S SLCTN=0 F S SLCTN=$O(^IBE(357.3,"C",IBLIST,SLCTN)) Q:'SLCTN D:$P($G(^IBE(357.3,SLCTN,0)),"^",3)=IBLIST CHANGE(SLCTN,SUBCOL,TYPE)
;
S VALMBCK="R"
Q
;
FORMAT2 ;allows the user to format all of the selections in the group in mass
;
;
;TYPE = type of formating - U=upper case,L=lower case,C=capitalize
;SUBCOL is the subcolumn to format
;
N TYPE,SUBCOL,SLCTN
;
;ask for the subcolumn to format
S SUBCOL=$$SUBCOL
;
;ask forthe type of fomatting
S TYPE=$S(SUBCOL:$$TYPE,1:"")
;
;find all the sections to be formatted and do so
I TYPE'="",SUBCOL S SLCTN=0 F S SLCTN=$O(^IBE(357.3,"D",IBGRP,SLCTN)) Q:'SLCTN D:$P($G(^IBE(357.3,SLCTN,0)),"^",4)=IBGRP CHANGE(SLCTN,SUBCOL,TYPE)
;
D IDXSLCTN^IBDF4
S VALMBCK="R"
Q
;
TYPE() ;ask the user what type of formatting
N TYPE S TYPE=""
K DIR S DIR(0)="SOB^UPPERCASE:U;LOWERCASE:L;CAPITALIZE:C"
S DIR("A")="Select the type of formatting",DIR("B")="C"
D ^DIR K DIR
I '$D(DIRUT),Y'=-1 S TYPE=Y
Q $E(TYPE,1)
;
CHANGE(SLCTN,SUBCOL,TYPE) ;
;
N DA,NODE,STR
S DA=$O(^IBE(357.3,SLCTN,1,"B",SUBCOL,0))
Q:'DA
S NODE=$G(^IBE(357.3,SLCTN,1,DA,0))
S STR=$P(NODE,"^",2)
D:$L(STR)
.I TYPE="U" S STR=$$UP^XLFSTR(STR)
.I TYPE="L" S STR=$$LOW^XLFSTR(STR)
.I TYPE="C" S STR=$$CAPS(STR)
.S $P(^IBE(357.3,SLCTN,1,DA,0),"^",2)=STR
Q
;
CAPS(STR) ;returns STR with each word in it capitalized
N FIRST,I,CHAR,LEN
S FIRST=1,LEN=$L(STR)
F I=1:1 S CHAR=$E(STR,I) Q:CHAR="" D
.I CHAR?1A,FIRST D
..S FIRST=0,CHAR=$$UP^XLFSTR(CHAR)
.E I CHAR?1A D
..S CHAR=$$LOW^XLFSTR(CHAR)
.E S FIRST=1
.S STR=$E(STR,1,I-1)_CHAR_$E(STR,I+1,LEN)
Q STR
;
SUBCOL() ;ask what subcolumn to format
;SCLIST - used to record the subcolumns that can be formated - each digit will signify a subcolum
;
N SCLIST,NODE,SUBCOL,ANS
;first get the list of subcolumns that can be formatted
S SCLIST="",SUBCOL=0
F S SUBCOL=$O(IBLIST("SCTYPE",SUBCOL)) Q:'SUBCOL I $G(IBLIST("SCW",SUBCOL)),IBLIST("SCTYPE",SUBCOL)=1,IBLIST("SCEDITABLE",SUBCOL) S SCLIST=SCLIST_","_SUBCOL
;if there is at most one subcolumn that can be edited return that
I $L(SCLIST)<3 Q $E(SCLIST,2)
;
;now ask what subcolumn to format
AGAIN W !,"What subcolumn do you want formated? Choose from (",$E(SCLIST,2,10),"): "
R ANS:DTIME
I '$T!(ANS["^") Q ""
I ANS?1N,SCLIST[ANS Q ANS
G AGAIN
Q ANS
IBDF9A1 ;ALB/CJM - ENCOUNTER FORM - (create,edit,delete selection list - continued) ;FEB 1,1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
NEWLIST ;creates a new list
+1 ;expects IBBLK to be defined
+2 NEW IBLIST,IBLEN,IBP,IBRTN,NAME,IBDELETE,IBDYN,IBINPUT,IBDFLTF,IBDFLTB,IBDFLTL
+3 SET (IBDFLTF,IBDFLTB,IBDFLTL,IBOLD,IBLIST)=0
SET VALMBCK="R"
+4 DO FULL^VALM1
+5 SET IBRTN=$$RTN^IBDF9A
IF 'IBRTN
QUIT
+6 SET IBDFLTF=$$DFLTS^IBDFU5
IF IBDFLTF
Begin DoDot:1
+7 SET IBDFLTB=0
FOR
SET IBDFLTB=$ORDER(^IBE(357.1,"C",IBDFLTF,IBDFLTB))
IF 'IBDFLTB
QUIT
Begin DoDot:2
+8 SET IBDFLTL=0
FOR
SET IBDFLTL=$ORDER(^IBE(357.2,"C",IBDFLTB,IBDFLTL))
IF 'IBDFLTL
QUIT
IF $PIECE($GET(^IBE(357.2,IBDFLTL,0)),"^",11)=IBRTN
QUIT
End DoDot:2
IF IBDFLTL
QUIT
End DoDot:1
+9 IF IBDFLTL
Begin DoDot:1
+10 SET IBLIST=$$COPYLIST^IBDFU2(IBDFLTL,IBDFLTB,IBBLK,357.2,357.2)
+11 IF 'IBLIST
QUIT
+12 KILL DIE,DA,DR
SET DIE=357.2
SET DA=IBLIST
SET DR="[IBDF POSITION/SIZE COLUMNS]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA
+13 SET VALMBCK="R"
DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
IF IBLIST
QUIT
+14 SET NAME=$$NEWNAME^IBDF9A
IF NAME=-1
QUIT
+15 KILL DIC,DIE,DD,DO,DINUM,DA
+16 NEW DLAYGO
+17 SET DIC="^IBE(357.2,"
SET DIC(0)="FL"
SET X=NAME
SET DLAYGO=357.2
+18 DO FILE^DICN
KILL DIC,DA
+19 SET IBLIST=$SELECT(+Y<0:"",1:+Y)
+20 IF 'IBLIST
Begin DoDot:1
+21 WRITE !,"Unable to create a new selection list!"
DO PAUSE^IBDFU5
End DoDot:1
+22 IF IBLIST
Begin DoDot:1
+23 ;deletes anything that may have been left lying around that now points to IBLIST
DO DLISTCNT^IBDFU3(IBLIST,357.2)
+24 KILL DIE,DA,DR
SET DIE=357.2
SET DA=IBLIST
SET DR="[IBDF EDIT SELECTION LIST]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA
+25 IF IBDELETE
KILL DA
SET DIK="^IBE(357.2,"
SET DA=IBLIST
DO ^DIK
KILL DIK,DA
+26 IF IBLIST
IF 'IBDELETE
DO ADDGROUP("BLANK",0)
+27 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+28 SET VALMBCK="R"
+29 QUIT
ADDGROUP(NAME,ORDER) ;adds a group to the selection list=IBLIST
+1 NEW GROUP
+2 KILL DIC,DIE,DD,DO,DINUM,DA
+3 NEW DLAYGO
+4 SET DIC="^IBE(357.4,"
SET DIC(0)="FL"
SET X=NAME
SET DLAYGO=357.4
+5 DO FILE^DICN
KILL DIC,DA
+6 SET GROUP=$SELECT(+Y<0:"",1:+Y)
+7 IF GROUP
Begin DoDot:1
+8 SET NODE=$GET(^IBE(357.4,GROUP,0))
SET $PIECE(NODE,"^",2)=ORDER
SET $PIECE(NODE,"^",3)=IBLIST
SET ^IBE(357.4,GROUP,0)=NODE
+9 SET DIK="^IBE(357.4,"
SET DA=GROUP
DO IX1^DIK
KILL DIK,DA
End DoDot:1
+10 QUIT
+11 ;
FORMAT ;allows the user to format all of the selections on the list in mass
+1 ;
+2 ;
+3 ;TYPE = type of formating - U=upper case,L=lower case,C=capitalize
+4 ;SUBCOL is the subcolumn to format
+5 ;
+6 NEW TYPE,SUBCOL,SLCTN
+7 ;
+8 ;ask for the subcolumn to format
+9 SET SUBCOL=$$SUBCOL
+10 ;
+11 ;ask for the type of fomatting
+12 SET TYPE=$SELECT(SUBCOL:$$TYPE,1:"")
+13 ;
+14 ;find all the sections to be formatted and do so
+15 IF TYPE'=""
IF SUBCOL
SET SLCTN=0
FOR
SET SLCTN=$ORDER(^IBE(357.3,"C",IBLIST,SLCTN))
IF 'SLCTN
QUIT
IF $PIECE($GET(^IBE(357.3,SLCTN,0)),"^",3)=IBLIST
DO CHANGE(SLCTN,SUBCOL,TYPE)
+16 ;
+17 SET VALMBCK="R"
+18 QUIT
+19 ;
FORMAT2 ;allows the user to format all of the selections in the group in mass
+1 ;
+2 ;
+3 ;TYPE = type of formating - U=upper case,L=lower case,C=capitalize
+4 ;SUBCOL is the subcolumn to format
+5 ;
+6 NEW TYPE,SUBCOL,SLCTN
+7 ;
+8 ;ask for the subcolumn to format
+9 SET SUBCOL=$$SUBCOL
+10 ;
+11 ;ask forthe type of fomatting
+12 SET TYPE=$SELECT(SUBCOL:$$TYPE,1:"")
+13 ;
+14 ;find all the sections to be formatted and do so
+15 IF TYPE'=""
IF SUBCOL
SET SLCTN=0
FOR
SET SLCTN=$ORDER(^IBE(357.3,"D",IBGRP,SLCTN))
IF 'SLCTN
QUIT
IF $PIECE($GET(^IBE(357.3,SLCTN,0)),"^",4)=IBGRP
DO CHANGE(SLCTN,SUBCOL,TYPE)
+16 ;
+17 DO IDXSLCTN^IBDF4
+18 SET VALMBCK="R"
+19 QUIT
+20 ;
TYPE() ;ask the user what type of formatting
+1 NEW TYPE
SET TYPE=""
+2 KILL DIR
SET DIR(0)="SOB^UPPERCASE:U;LOWERCASE:L;CAPITALIZE:C"
+3 SET DIR("A")="Select the type of formatting"
SET DIR("B")="C"
+4 DO ^DIR
KILL DIR
+5 IF '$DATA(DIRUT)
IF Y'=-1
SET TYPE=Y
+6 QUIT $EXTRACT(TYPE,1)
+7 ;
CHANGE(SLCTN,SUBCOL,TYPE) ;
+1 ;
+2 NEW DA,NODE,STR
+3 SET DA=$ORDER(^IBE(357.3,SLCTN,1,"B",SUBCOL,0))
+4 IF 'DA
QUIT
+5 SET NODE=$GET(^IBE(357.3,SLCTN,1,DA,0))
+6 SET STR=$PIECE(NODE,"^",2)
+7 IF $LENGTH(STR)
Begin DoDot:1
+8 IF TYPE="U"
SET STR=$$UP^XLFSTR(STR)
+9 IF TYPE="L"
SET STR=$$LOW^XLFSTR(STR)
+10 IF TYPE="C"
SET STR=$$CAPS(STR)
+11 SET $PIECE(^IBE(357.3,SLCTN,1,DA,0),"^",2)=STR
End DoDot:1
+12 QUIT
+13 ;
CAPS(STR) ;returns STR with each word in it capitalized
+1 NEW FIRST,I,CHAR,LEN
+2 SET FIRST=1
SET LEN=$LENGTH(STR)
+3 FOR I=1:1
SET CHAR=$EXTRACT(STR,I)
IF CHAR=""
QUIT
Begin DoDot:1
+4 IF CHAR?1A
IF FIRST
Begin DoDot:2
+5 SET FIRST=0
SET CHAR=$$UP^XLFSTR(CHAR)
End DoDot:2
+6 IF '$TEST
IF CHAR?1A
Begin DoDot:2
+7 SET CHAR=$$LOW^XLFSTR(CHAR)
End DoDot:2
+8 IF '$TEST
SET FIRST=1
+9 SET STR=$EXTRACT(STR,1,I-1)_CHAR_$EXTRACT(STR,I+1,LEN)
End DoDot:1
+10 QUIT STR
+11 ;
SUBCOL() ;ask what subcolumn to format
+1 ;SCLIST - used to record the subcolumns that can be formated - each digit will signify a subcolum
+2 ;
+3 NEW SCLIST,NODE,SUBCOL,ANS
+4 ;first get the list of subcolumns that can be formatted
+5 SET SCLIST=""
SET SUBCOL=0
+6 FOR
SET SUBCOL=$ORDER(IBLIST("SCTYPE",SUBCOL))
IF 'SUBCOL
QUIT
IF $GET(IBLIST("SCW",SUBCOL))
IF IBLIST("SCTYPE",SUBCOL)=1
IF IBLIST("SCEDITABLE",SUBCOL)
SET SCLIST=SCLIST_","_SUBCOL
+7 ;if there is at most one subcolumn that can be edited return that
+8 IF $LENGTH(SCLIST)<3
QUIT $EXTRACT(SCLIST,2)
+9 ;
+10 ;now ask what subcolumn to format
AGAIN WRITE !,"What subcolumn do you want formated? Choose from (",$EXTRACT(SCLIST,2,10),"): "
+1 READ ANS:DTIME
+2 IF '$TEST!(ANS["^")
QUIT ""
+3 IF ANS?1N
IF SCLIST[ANS
QUIT ANS
+4 GOTO AGAIN
+5 QUIT ANS
