source: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF4.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1IBDF4 ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(editing group's selections) ;NOV 16,1992
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**19,38,56**;APR 24, 1997
3 ;
4SLCTNS ;
5 N IBRTN
6 Q:IBLIST'=$P($G(^IBE(357.4,IBGRP,0)),"^",3)
7 S IBRTN=IBLIST("RTN")
8 D RTNDSCR^IBDFU1B(.IBRTN)
9 D KILL^IBDFUA
10 D EN^VALM("IBDF EDIT GROUP'S SELECTIONS") ;call the list manager
11 Q
12ONENTRY ;entry code for list manager
13 D IDXSLCTN
14 Q
15ONEXIT ;exit code for the list manager
16 K @VALMAR
17 Q
18 ;
19IDXSLCTN ;build an array of selections in print order for the list processor
20 N SLCTN,ODR,NODE
21 K @VALMAR
22 S ODR="",VALMCNT=0
23 F S ODR=$O(^IBE(357.3,"APO",IBLIST,IBGRP,ODR)) Q:ODR="" D
24 .S SLCTN="" F S SLCTN=$O(^IBE(357.3,"APO",IBLIST,IBGRP,ODR,SLCTN)) Q:'SLCTN D
25 ..;check for messed up index and take appropriate action
26 ..S NODE=$G(^IBE(357.3,SLCTN,0))
27 ..I ($P(NODE,"^",3)'=IBLIST)!($P(NODE,"^",4)'=IBGRP) D Q
28 ...K ^IBE(357.3,"APO",IBLIST,IBGRP,ODR,SLCTN)
29 ...I $P(NODE,"^",3)'=IBLIST,$P(NODE,"^",4)=IBGRP D Q
30 ....K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN D ^DIK K DIK,DA
31 ...I $P(NODE,"^",3)=IBLIST,$P($G(^IBE(357.4,+IBGRP,0)),"^",3)'=IBLIST D Q
32 ....K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN D ^DIK K DIK,DA
33 ...K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN D IX^DIK K DIK,DA
34 ..;
35 ..S VALMCNT=VALMCNT+1
36 ..S @VALMAR@(VALMCNT,0)=$$DISPLAY(SLCTN,VALMCNT),@VALMAR@("IDX",VALMCNT,VALMCNT)=SLCTN
37 ..D FLDCTRL^VALM10(VALMCNT,"ID") ;set video for ID column
38 Q
39LMGRPHDR ;header for the screen
40 S VALMHDR(1)="SELECTIONS CURRENTLY DEFINED FOR '"_$$GRPNAME_"' PRINT GROUP"
41 Q
42 ;
43GRPNAME() ;the name of the selection group
44 Q $P($G(^IBE(357.4,IBGRP,0)),"^",1)
45 ;
46DISPLAY(SLCTN,COUNT) ;returns a line to display to the list containing a selection - SLCTN is a ptr to the selectin, COUNT is the number of the selection on the list
47 N SC,SCDA,VAL,RET,W,NODE,ORDER
48 ;W - an array cotaining the widths of the subcolumns that contain text
49 S VAL=""
50 S RET=$$PADRIGHT^IBDFU(COUNT,4)
51 S NODE=$G(^IBE(357.3,SLCTN,0))
52 S ORDER=$P(NODE,"^",5),RET=RET_$J(ORDER,6,2)
53 I $P(NODE,"^",2) S RET=RET_$S($P(NODE,"^",7):" SH",1:" PH")_"| "_$P(NODE,"^",6)
54 I '$P(NODE,"^",2) S RET=RET_" ",SC="" F SC=1:1:8 S SCDA=$O(^IBE(357.3,SLCTN,1,"B",SC,"")) D
55 .I $G(IBLIST("SCTYPE",SC))=1 S W(SC)=IBLIST("SCW",SC)*(1+IBLIST("BTWN"))
56 .S:$G(W(SC)) VAL=$$PADRIGHT^IBDFU($S(SCDA:$P($G(^IBE(357.3,SLCTN,1,SCDA,0)),"^",2),1:""),W(SC))
57 .S:VAL'="" RET=RET_" | "_VAL
58 .S VAL=""
59 I $D(^IBE(357.3,SLCTN,2)) S RET=RET_" ",SC="" F SC=1:1:2 S SCDA=$P(^IBE(357.3,SLCTN,2),"^",SC) S:SC=2 SCDA=$S($D(^LEX)>1:$P($G(^LEX(757.01,+SCDA,0)),"^"),1:$P($G(^GMP(757.01,+SCDA,0)),"^")) D
60 .S W(SC)=25
61 .S VAL=$$PADRIGHT^IBDFU($S(SCDA]"":SCDA,1:""),W(SC))
62 .S:VAL'="" RET=RET_" | "_VAL
63 .S VAL=""
64 Q RET
65ADDSLCTN ;allows the user to add a selection to the selection group
66 N QUIT,SUB
67 ;
68 S VALMBCK="R"
69 D FULL^VALM1
70 I IBRTN("ACTION")'=3 D NOGOOD G ADDEXIT
71 K @IBRTN("DATA_LOCATION")
72 S QUIT=0 F D Q:QUIT W !!!,"Now for another SELECTION LIST entry!"
73 .I '$$DORTN^IBDFU1B(.IBRTN) S QUIT=1 D NOGOOD Q
74 .I '$D(@IBRTN("DATA_LOCATION")) S QUIT=1 Q
75 .D ADDREC(.QUIT) ;edits and adds the selection
76 .K @IBRTN("DATA_LOCATION")
77ADDEXIT ;
78 D IDXSLCTN
79 Q
80ADDREC(QUIT,ORDER,SLCTN) ;allows the user to number the selection, edit the editable subcolumns, then adds the record - sets QUIT=1 if user quits
81 N SUB,COUNT,NODE,VAL,DLAYGO,QTY,DTOUT,DUOUT,DIRUT
82 I $P($G(^IBE(357.6,$P($G(^IBE(357.2,+IBLIST,0)),"^",11),16)),"^",8) S DIR(0)="NO",DIR("A")="Quantity",DIR("B")=1,DIR("?")="Enter the number of occurrences" D ^DIR K DIR S:$D(DTOUT)!$D(DUOUT) QUIT=1 Q:QUIT S QTY=$G(Y)
83 I '$G(ORDER) D Q:QUIT
84 .K DIR S DIR(0)="357.3,.05",DIR("B")=$$NEXT^IBDF4A(IBLIST,IBGRP) D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
85 .S ORDER=+Y
86 S VAL=$G(@IBRTN("DATA_LOCATION"))
87 Q:QUIT
88 ;we have all the data needed to add the selection - so add it
89 S NODE=$S($P(VAL,"^")'="":$P(VAL,"^"),1:ORDER)_"^^"_IBLIST_"^"_IBGRP_"^"_ORDER_$S($G(QTY):"^^^^"_QTY,1:"")
90 K DIC,DD,DO,DINUM S DIC="^IBE(357.3,",X=$P(NODE,"^",1),DIC(0)="FL",DLAYGO=357.3
91 D FILE^DICN K DIC,DIE,DA
92 S SLCTN=$S(+Y<0:"",1:+Y)
93 I 'SLCTN W !,"Unable to create a new selection record!" D PAUSE^VALM1 S QUIT=1 Q
94 S ^IBE(357.3,SLCTN,0)=NODE
95 ;--- move codes and add modifiers
96 D CODES^IBDF4A,ADD^IBDF4C
97 ;---move the subcolum set up
98 F SUB=1:1:8 D Q:QUIT
99 .I $G(IBLIST("SCTYPE",SUB))=1 I IBLIST("SCPIECE",SUB),IBLIST("SCW",SUB) D
100 ..S NODE=$$DATANODE^IBDFU1B(IBRTN,IBLIST("SCPIECE",SUB))
101 ..I NODE]"" S VAL(SUB)=$P($G(@IBRTN("DATA_LOCATION")@(NODE)),"^",IBLIST("SCPIECE",SUB))
102 ..E S VAL(SUB)=$P(VAL,"^",IBLIST("SCPIECE",SUB))
103 ..Q:('IBLIST("SCEDITABLE",SUB))!((IBRTN("WIDTH",1))&(IBLIST("SCPIECE",SUB)=1))
104 ..W !!,"Subcolumn Header: "_IBLIST("SCHDR",SUB) K DIR S DIR(0)="FO^0:"_(IBLIST("SCW",SUB)*(1+IBLIST("BTWN"))),DIR("A")="Edit Subcolumn "_SUB,DIR("B")=VAL(SUB)_$S($G(QTY)>1:" x "_QTY,1:"")
105 ..I $P($G(^IBE(357.3,SLCTN,3,0)),"^",4)>0 D
106 ...S:DIR("B")'["w/ mod" DIR("B")=DIR("B")_"w/ mod"
107 ..D ^DIR K DIR S:$D(DTOUT)!$D(DUOUT) QUIT=1 Q:QUIT S VAL(SUB)=Y I IBLIST("SCPIECE",SUB)=1,X="" S QUIT=1
108 ;
109 ;add the subcolumn value multiple
110 S COUNT=0 F SUB=1:1:8 I $G(VAL(SUB))'="" S COUNT=COUNT+1,^IBE(357.3,SLCTN,1,COUNT,0)=SUB_"^"_VAL(SUB)
111 S ^IBE(357.3,SLCTN,1,0)="^357.31IA^"_COUNT_"^"_COUNT
112 K DA S DA=SLCTN,DIK="^IBE(357.3," D IX^DIK K DIK,DA
113 D NARR,TERM
114 Q
115 ;
116NARR ; -- edit provider narrative, but only for selections where the
117 ; interface allows editing
118 N DIE,DA,DR
119 I $P($G(^IBE(357.6,+$P($G(^IBE(357.2,+IBLIST,0)),U,11),0)),U,17) D
120 .S DIE="^IBE(357.3,",DA=SLCTN,DR=2.01 D ^DIE K DIE,DA,DR
121 Q
122 ;
123TERM ; -- map selection to clinical lexicon, but only for selections where
124 ; the package interface allows editing
125 N DIE,DA,DR,GMPTUN,GMPTSUB,GMPTSHOW,XTLKGLB,XTLKHLP,XTLKKSCH,XTLKSAY,IBDLEX
126 I $P($G(^IBE(357.6,+$P($G(^IBE(357.2,+IBLIST,0)),U,11),0)),U,18) D
127 .I $D(^LEX)>1 S X="LEXSET" X ^%ZOSF("TEST") I $T D CONFIG^LEXSET("GMPL","PL1") S IBDLEX=1
128 .I '$D(IBDLEX) S X="GMPTSET" X ^%ZOSF("TEST") I $T D CONFIG^GMPTSET("GMPL","PL1") S IBDLEX=1
129 .;D CONFIG^GMPTSET("ICD","ICD") (this is an alternate filter)
130 .Q:'$D(IBDLEX)
131 .S DIE="^IBE(357.3,",DA=SLCTN,DR="2.02//"_$P($G(^IBE(357.3,DA,0)),"^") D ^DIE
132 K DIC
133 Q
134 ;
135CODES ; -- allow selection of a second code to pass through for this entry
136 ; -- only as if pi allows input of more than one code
137 ;N PI S PI=+$P($G(^IBE(357.2,+IBLIST,0)),U,11)
138 ;Q:'$P($G(^IBE(357.6,PI,16)),U,9)
139 ;N IBI,QUIT,IBVAL S QUIT=0
140 ;F IBI=1,2 D Q:QUIT
141 ;.W !,"****Select a ",$S(IBI=1:"second",1:"third")," code to pass along with original."
142 ;.I '$$DORTN^IBDFU1B(.IBRTN) S QUIT=1 Q
143 ;.I +Y'>0 S QUIT=1 Q
144 ;.X $G(^IBE(357.6,PI,9)) S IBVAL=X
145 ;.S DIE="^IBE(357.3,",DA=SLCTN,DR=$S(IBI=1:"2.03",1:"2.04")_"////^S X=IBVAL" D ^DIE K DIE,DA,DR
146 ;Q
147 ;
148NOGOOD ;
149 W !,"The package interface routine for selection is not properly defined" D PAUSE^VALM1
150 Q
151 ;
152SEQUENCE ;allows the user to resequence all of the selections on the list
153 ;
154 N SUBCOL,CNT,P,SORT,GROUP,NODE,VALUE,ITEM,IEN,HDR,DTOUT,DUOUT,DIRUT,SORT1
155 S VALMBCK="R"
156 D FULL^VALM1
157 ;
158 ;sort by which subcolumn?
159 K DIR S DIR("A")="Which subcolumn do you want to sort by?",DIR("?")=" "
160 S SUBCOL=0 F S SUBCOL=$O(IBLIST("SCTYPE",SUBCOL)) Q:'SUBCOL I IBLIST("SCTYPE",SUBCOL)=1 S SUBCOL(SUBCOL)=""
161 S (CNT,SUBCOL)=0,DIR(0)="SOX^"
162 F CNT=1:1 S SUBCOL=$O(SUBCOL(SUBCOL)) Q:'SUBCOL D
163 .S P=IBLIST("SCPIECE",SUBCOL),P=$S(P=1:1,P=2:3,P=3:5,P=4:7,P=5:9,P=6:11,P=7:13,1:0),HDR=$P($G(^IBE(357.6,+IBLIST("RTN"),2)),"^",P),DIR("?",CNT)=SUBCOL_" = "_HDR
164 .S HDR=$S($G(IBLIST("SCHDR",SUBCOL))="":HDR,1:IBLIST("SCHDR",SUBCOL))
165 .S DIR(0)=DIR(0)_SUBCOL_":"_HDR_";"
166 D ^DIR
167 Q:$D(DIRUT)!(Y=-1)
168 K SUBCOL S SUBCOL=+Y
169 ;
170 ;sort aphabetically or numerically?
171 K DIR
172 S DIR("A")="How should the list be sorted?",DIR(0)="SO^1:ALPHABETICALLY;2:NUMERICALLY;",DIR("B")="ALPHABETICALLY"
173 D ^DIR
174 Q:$D(DIRUT)!(Y=-1)
175 S SORT=Y
176 ; -- Resequence by group or group and placeholders
177 K DIR
178 S DIR("A")="Resequence by Group or Group and Place Holders?",DIR(0)="SO^1:GROUP/PLACE HOLDERS;2:GROUP;",DIR("B")="GROUP/PLACE HOLDERS"
179 D ^DIR
180 Q:$D(DIRUT)!(Y=-1)
181 S SORT1=Y
182 ;
183 ;sort
184 I SORT1=2 D EN^IBDF4A Q
185 N CNTR,GROUP1,IBGROUP,IBORDER
186 K ^TMP("IBDF",$J)
187 S (GROUP,GROUP1,CNTR,IBGROUP)=0
188 ; -- Resequence only specific groups in block.
189 I $D(IBGRUP) F S IBGROUP=$O(IBGRUP(IBGROUP)) Q:'IBGROUP D RESEQ
190 I $D(IBGRUP) D ORDER Q
191 ; -- Resequence all groups of the block.
192 I '$D(IBGRUP) F S IBGROUP=$O(^IBE(357.3,"APO",IBLIST,IBGROUP)) Q:'IBGROUP D RESEQ
193 I '$D(IBGRUP) D ORDER Q
194 Q
195RESEQ S IBORDER=0 F S IBORDER=$O(^IBE(357.3,"APO",IBLIST,IBGROUP,IBORDER)) Q:'IBORDER S ITEM=0 F S ITEM=$O(^IBE(357.3,"APO",IBLIST,IBGROUP,IBORDER,ITEM)) Q:'ITEM D
196 .S NODE=$G(^IBE(357.3,ITEM,0))
197 .I ($P(NODE,"^",3)'=IBLIST) Q
198 .S GROUP1=GROUP,GROUP=+$P(NODE,"^",4)
199 .Q:$P($G(^IBE(357.4,GROUP,0)),"^",3)'=IBLIST
200 .I $P(NODE,"^",2)=1 D Q
201 ..S CNTR=CNTR+1
202 ..S VALUE=$S(SORT=1:" ",1:+$P(NODE,"^",1))
203 ..S ^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR,VALUE,ITEM)=""
204 .S IEN=$O(^IBE(357.3,ITEM,1,"B",SUBCOL,0)) Q:'IEN
205 .S VALUE=$P($G(^IBE(357.3,ITEM,1,IEN,0)),"^",2)
206 .S VALUE=$S(SORT=1:VALUE=" "_VALUE,1:+$P(NODE,"^",1))
207 .I GROUP'=GROUP1 S CNTR=CNTR+1
208 .S ^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR,$E(VALUE,1,40),ITEM)=""
209 ;set the order
210ORDER S GROUP=0,CNTR=0
211 F S GROUP=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP)) Q:'GROUP D
212 .S VALUE="",CNT=0
213 .F S CNTR=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR)) Q:'CNTR F S VALUE=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR,VALUE)) Q:VALUE="" D
214 ..S ITEM=0 F S ITEM=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR,VALUE,ITEM)) Q:'ITEM D
215 ...S CNT=CNT+1
216 ...K DIE,DA,DR S DIE="^IBE(357.3,",DR=".05///"_CNT,DA=ITEM D ^DIE K DIE,DA,DR
217 ;
218 K Y,X,DIR,^TMP("IBDF",$J,"RESEQUENCE LIST")
219 D IDXGRP^IBDF3
220 Q
Note: See TracBrowser for help on using the repository browser.