source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF9A1.m@ 1450

Last change on this file since 1450 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.5 KB
RevLine 
[613]1IBDF9A1 ;ALB/CJM - ENCOUNTER FORM - (create,edit,delete selection list - continued) ;FEB 1,1993
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4NEWLIST ;creates a new list
5 ;expects IBBLK to be defined
6 N IBLIST,IBLEN,IBP,IBRTN,NAME,IBDELETE,IBDYN,IBINPUT,IBDFLTF,IBDFLTB,IBDFLTL
7 S (IBDFLTF,IBDFLTB,IBDFLTL,IBOLD,IBLIST)=0,VALMBCK="R"
8 D FULL^VALM1
9 S IBRTN=$$RTN^IBDF9A Q:'IBRTN
10 S IBDFLTF=$$DFLTS^IBDFU5 D:IBDFLTF
11 .S IBDFLTB=0 F S IBDFLTB=$O(^IBE(357.1,"C",IBDFLTF,IBDFLTB)) Q:'IBDFLTB D Q:IBDFLTL
12 ..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
13 I IBDFLTL D Q:IBLIST
14 .S IBLIST=$$COPYLIST^IBDFU2(IBDFLTL,IBDFLTB,IBBLK,357.2,357.2)
15 .Q:'IBLIST
16 .K DIE,DA,DR S DIE=357.2,DA=IBLIST,DR="[IBDF POSITION/SIZE COLUMNS]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
17 .S VALMBCK="R" D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
18 S NAME=$$NEWNAME^IBDF9A Q:NAME=-1
19 K DIC,DIE,DD,DO,DINUM,DA
20 N DLAYGO
21 S DIC="^IBE(357.2,",DIC(0)="FL",X=NAME,DLAYGO=357.2
22 D FILE^DICN K DIC,DA
23 S IBLIST=$S(+Y<0:"",1:+Y)
24 I 'IBLIST D
25 .W !,"Unable to create a new selection list!" D PAUSE^IBDFU5
26 I IBLIST D
27 .D DLISTCNT^IBDFU3(IBLIST,357.2) ;deletes anything that may have been left lying around that now points to IBLIST
28 .K DIE,DA,DR S DIE=357.2,DA=IBLIST,DR="[IBDF EDIT SELECTION LIST]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
29 .I IBDELETE K DA S DIK="^IBE(357.2,",DA=IBLIST D ^DIK K DIK,DA
30 .I IBLIST,'IBDELETE D ADDGROUP("BLANK",0)
31 .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
32 S VALMBCK="R"
33 Q
34ADDGROUP(NAME,ORDER) ;adds a group to the selection list=IBLIST
35 N GROUP
36 K DIC,DIE,DD,DO,DINUM,DA
37 N DLAYGO
38 S DIC="^IBE(357.4,",DIC(0)="FL",X=NAME,DLAYGO=357.4
39 D FILE^DICN K DIC,DA
40 S GROUP=$S(+Y<0:"",1:+Y)
41 I GROUP D
42 .S NODE=$G(^IBE(357.4,GROUP,0)) S $P(NODE,"^",2)=ORDER,$P(NODE,"^",3)=IBLIST S ^IBE(357.4,GROUP,0)=NODE
43 .S DIK="^IBE(357.4,",DA=GROUP D IX1^DIK K DIK,DA
44 Q
45 ;
46FORMAT ;allows the user to format all of the selections on the list in mass
47 ;
48 ;
49 ;TYPE = type of formating - U=upper case,L=lower case,C=capitalize
50 ;SUBCOL is the subcolumn to format
51 ;
52 N TYPE,SUBCOL,SLCTN
53 ;
54 ;ask for the subcolumn to format
55 S SUBCOL=$$SUBCOL
56 ;
57 ;ask for the type of fomatting
58 S TYPE=$S(SUBCOL:$$TYPE,1:"")
59 ;
60 ;find all the sections to be formatted and do so
61 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)
62 ;
63 S VALMBCK="R"
64 Q
65 ;
66FORMAT2 ;allows the user to format all of the selections in the group in mass
67 ;
68 ;
69 ;TYPE = type of formating - U=upper case,L=lower case,C=capitalize
70 ;SUBCOL is the subcolumn to format
71 ;
72 N TYPE,SUBCOL,SLCTN
73 ;
74 ;ask for the subcolumn to format
75 S SUBCOL=$$SUBCOL
76 ;
77 ;ask forthe type of fomatting
78 S TYPE=$S(SUBCOL:$$TYPE,1:"")
79 ;
80 ;find all the sections to be formatted and do so
81 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)
82 ;
83 D IDXSLCTN^IBDF4
84 S VALMBCK="R"
85 Q
86 ;
87TYPE() ;ask the user what type of formatting
88 N TYPE S TYPE=""
89 K DIR S DIR(0)="SOB^UPPERCASE:U;LOWERCASE:L;CAPITALIZE:C"
90 S DIR("A")="Select the type of formatting",DIR("B")="C"
91 D ^DIR K DIR
92 I '$D(DIRUT),Y'=-1 S TYPE=Y
93 Q $E(TYPE,1)
94 ;
95CHANGE(SLCTN,SUBCOL,TYPE) ;
96 ;
97 N DA,NODE,STR
98 S DA=$O(^IBE(357.3,SLCTN,1,"B",SUBCOL,0))
99 Q:'DA
100 S NODE=$G(^IBE(357.3,SLCTN,1,DA,0))
101 S STR=$P(NODE,"^",2)
102 D:$L(STR)
103 .I TYPE="U" S STR=$$UP^XLFSTR(STR)
104 .I TYPE="L" S STR=$$LOW^XLFSTR(STR)
105 .I TYPE="C" S STR=$$CAPS(STR)
106 .S $P(^IBE(357.3,SLCTN,1,DA,0),"^",2)=STR
107 Q
108 ;
109CAPS(STR) ;returns STR with each word in it capitalized
110 N FIRST,I,CHAR,LEN
111 S FIRST=1,LEN=$L(STR)
112 F I=1:1 S CHAR=$E(STR,I) Q:CHAR="" D
113 .I CHAR?1A,FIRST D
114 ..S FIRST=0,CHAR=$$UP^XLFSTR(CHAR)
115 .E I CHAR?1A D
116 ..S CHAR=$$LOW^XLFSTR(CHAR)
117 .E S FIRST=1
118 .S STR=$E(STR,1,I-1)_CHAR_$E(STR,I+1,LEN)
119 Q STR
120 ;
121SUBCOL() ;ask what subcolumn to format
122 ;SCLIST - used to record the subcolumns that can be formated - each digit will signify a subcolum
123 ;
124 N SCLIST,NODE,SUBCOL,ANS
125 ;first get the list of subcolumns that can be formatted
126 S SCLIST="",SUBCOL=0
127 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
128 ;if there is at most one subcolumn that can be edited return that
129 I $L(SCLIST)<3 Q $E(SCLIST,2)
130 ;
131 ;now ask what subcolumn to format
132AGAIN W !,"What subcolumn do you want formated? Choose from (",$E(SCLIST,2,10),"): "
133 R ANS:DTIME
134 I '$T!(ANS["^") Q ""
135 I ANS?1N,SCLIST[ANS Q ANS
136 G AGAIN
137 Q ANS
Note: See TracBrowser for help on using the repository browser.