138 lines
4.5 KiB
Mathematica
138 lines
4.5 KiB
Mathematica
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
|