source: WorldVistAEHR/trunk/r/PROBLEM_LIST-GMPL/GMPLBLD2.m@ 1800

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

initial load of WorldVistAEHR
File size: 6.9 KB
Line 
1GMPLBLD2 ; SLC/MKB,JFR -- Bld PL Selection Lists cont ; 3/14/03 11:20
2 ;;2.0;Problem List;**3,28**;Aug 25, 1994
3 ;
4 ; This routine invokes IA #3991
5 ;
6NEWGRP ; Change problem groups
7 N NEWGRP D FULL^VALM1
8 I $D(GMPLSAVE),$$CKSAVE D SAVE
9NG1 S NEWGRP=$$GROUP("L") G:+NEWGRP'>0 NGQ G:+NEWGRP=+GMPLGRP NGQ
10 L +^GMPL(125.11,+NEWGRP,0):1 I '$T D G NG1
11 . W $C(7),!!,"This category is currently being edited by another user!",!
12 L -^GMPL(125.11,+GMPLGRP,0) S GMPLGRP=NEWGRP
13 D GETLIST^GMPLBLDC,BUILD^GMPLBLDC("^TMP(""GMPLIST"",$J)",GMPLMODE),HDR^GMPLBLDC
14NGQ S VALMBCK="R",VALMSG=$$MSG^GMPLX
15 Q
16 ;
17GROUP(L) ; Lookup into Problem Selection Group file #125.11
18 N DIC,X,Y,DLAYGO ; L = "" or "L", if LAYGO is [not] allowed
19 S DIC="^GMPL(125.11,",DIC(0)="AEQMZ"_L,DIC("A")="Select CATEGORY NAME: "
20 S:DIC(0)["L" DLAYGO=125.11
21 D ^DIC S:Y'>0 Y="^" S:Y'="^" Y=+Y_U_Y(0)
22 Q Y
23 ;
24NEWLST ; Change selection lists
25 N NEWLST D FULL^VALM1
26 I $D(GMPLSAVE),$$CKSAVE D SAVE
27NL1 S NEWLST=$$LIST("L") G:+NEWLST'>0 NLQ G:+NEWLST=+GMPLSLST NLQ
28 L +^GMPL(125,+NEWLST,0):1 I '$T D G NL1
29 . W $C(7),!!,"This list is currently being edited by another user!",!
30 L -^GMPL(125,+GMPLSLST,0) S GMPLSLST=NEWLST
31 D GETLIST^GMPLBLD,BUILD^GMPLBLD("^TMP(""GMPLIST"",$J)",GMPLMODE),HDR^GMPLBLD
32NLQ S VALMBCK="R",VALMSG=$$MSG^GMPLX
33 Q
34 ;
35LIST(L) ; Lookup into Problem Selection List file #125
36 N DIC,X,Y,DLAYGO ; L="" or "L" if LAYGO [not] allowed
37 S DIC="^GMPL(125,",DIC(0)="AEQMZ"_L,DIC("A")="Select LIST NAME: "
38 S:DIC(0)["L" DLAYGO=125
39 D ^DIC S:Y'>0 Y="^" S:Y'="^" Y=+Y_U_Y(0)
40 Q Y
41 ;
42LAST(ROOT) ; Returns last subscript
43 N I,J S (I,J)=""
44 F S I=$O(@(ROOT_"I)")) Q:I="" S J=I
45 Q J
46 ;
47CKSAVE() ; Save [changes] ??
48 N DIR,X,Y,TEXT S TEXT=$S($D(GMPLGRP):"category",1:"list")
49 S DIR("A")="Save the changes to this "_TEXT_"? ",DIR("B")="YES"
50 S DIR("?",1)="Enter YES to save the changes that have been made to this "_TEXT,DIR("?")="before exiting it; NO will leave this "_TEXT_" unchanged."
51 S DIR(0)="YA" D ^DIR
52 Q +Y
53 ;
54SAVE ; Save changes to group/list
55 N GMPLQT,LABEL,DA
56 S GMPLQT=0
57 I $D(GMPLGRP) D I GMPLQT Q
58 . N ITM,CODE
59 . S ITM=0
60 . F S ITM=$O(^TMP("GMPLIST",$J,ITM)) Q:'ITM!(GMPLQT) D
61 .. S CODE=$P(^TMP("GMPLIST",$J,ITM),U,4) Q:'$L(CODE)
62 .. I '$$STATCHK^ICDAPIU(CODE,DT) S GMPLQT=1 Q
63 . I 'GMPLQT Q ;no inactive codes in the category
64 . D FULL^VALM1
65 . W !!,$C(7),"This Group contains problems with inactive ICD9 codes associated with them."
66 . W !,"The codes must be edited and corrected before the group can be saved."
67 . N DIR,DUOUT,DTOUT,DIRUT
68 . S DIR(0)="E" D ^DIR
69 . S VALMBCK="R",GMPLQT=1
70 . Q
71 ;
72 I '$D(GMPLGRP),$D(GMPLSLST) D I GMPLQT Q
73 . N GRP
74 . S GRP=0
75 . F S GRP=$O(^TMP("GMPLIST",$J,"GRP",GRP)) Q:'GRP!(GMPLQT) D
76 .. I $$VALGRP(GRP) Q ;no inactive codes in the GROUP
77 .. S GMPLQT=1
78 . I 'GMPLQT Q ; all groups and problems OK
79 . D FULL^VALM1
80 . W !!,$C(7),"This Selection List contains problems with inactive ICD9 codes associated with"
81 . W !,"them. The codes must be edited and corrected before the list can be saved."
82 . N DIR,DUOUT,DTOUT,DIRUT
83 . S DIR(0)="E" D ^DIR
84 . S VALMBCK="R",GMPLQT=1
85 . Q
86 W !!,"Saving ..."
87 S DA=0,LABEL=$S($D(GMPLGRP):"SAVGRP",1:"SAVLST")
88 F S DA=$O(^TMP("GMPLIST",$J,DA)) Q:+DA'>0 D @LABEL
89 K GMPLSAVE S:$D(GMPLGRP) GMPSAVED=1
90 S VALMBCK="Q" W " done." H 1
91 Q
92SAVGRP ; Save changes to existing group
93 N DIK,DIE,DR,ITEM,TMPITEM
94 S DIK="^GMPL(125.12,"
95 I +DA'=DA D Q
96 . Q:"@"[$G(^TMP("GMPLIST",$J,DA)) ; nothing to save
97 . S TMPITEM=^TMP("GMPLIST",$J,DA) D NEW(DIK,+GMPLGRP,TMPITEM)
98 I "@"[$G(^TMP("GMPLIST",$J,DA)) D ^DIK Q
99 S ITEM=$P($G(^GMPL(125.12,DA,0)),U,2,5)
100 I ITEM'=^TMP("GMPLIST",$J,DA) D
101 . S DR="",DIE=DIK
102 . F I=1:1:4 D
103 .. S:$P(^TMP("GMPLIST",$J,DA),U,I)'=$P(ITEM,U,I) DR=DR_";"_I_"////"_$S($P(^TMP("GMPLIST",$J,DA),U,I)="":"@",1:$P(^TMP("GMPLIST",$J,DA),U,I))
104 . S:$E(DR)=";" DR=$E(DR,2,999) D ^DIE
105 Q
106 ;
107SAVLST ; Save changes to existing list
108 N DIK,DIE,DR,ITEM,TMPLST
109 S DIK="^GMPL(125.1,"
110 I +DA'=DA D Q ; new link
111 . Q:"@"[$G(^TMP("GMPLIST",$J,DA)) ; nothing to save
112 . S TMPLST=^TMP("GMPLIST",$J,DA) D NEW(DIK,+GMPLSLST,TMPLST)
113 I "@"[$G(^TMP("GMPLIST",$J,DA)) D ^DIK Q
114 S ITEM=$P($G(^GMPL(125.1,DA,0)),U,2,5)
115 I ITEM'=^TMP("GMPLIST",$J,DA) D
116 . S DR="",DIE=DIK
117 . F I=1,2,3,4 D
118 .. S:$P(^TMP("GMPLIST",$J,DA),U,I)'=$P(ITEM,U,I) DR=DR_";"_I_"////"_$S($P(^TMP("GMPLIST",$J,DA),U,I)="":"@",1:$P(^TMP("GMPLIST",$J,DA),U,I))
119 . S:$E(DR)=";" DR=$E(DR,2,999) D ^DIE
120 Q
121 ;
122NEW(DIK,LIST,ITEM) ; Create new entry in Contents file #125.1 or #125.12
123 N I,HDR,LAST,TOTAL,DA
124 S HDR=$G(@(DIK_"0)")),LAST=$P(HDR,U,3),TOTAL=$P(HDR,U,4)
125 F I=(LAST+1):1 Q:'$D(@(DIK_"I,0)"))
126 S DA=I,@(DIK_"DA,0)")=LIST_U_ITEM
127 S $P(@(DIK_"0)"),U,3,4)=DA_U_(TOTAL+1)
128 D IX1^DIK ; set Xrefs
129 Q
130 ;
131DELETE ; Delete problem group
132 N DIR,X,Y,DA,DIK,IFN S VALMBCK=$S(VALMCC:"",1:"R")
133 I $D(^GMPL(125.1,"G",+GMPLGRP)) W $C(7),!!,">>> This category belongs to at least one problem selection list!",!," CANNOT DELETE" H 2 Q
134 S DIR(0)="YA",DIR("B")="NO",DIR("A")="Are you sure you want to delete the entire '"_$P(GMPLGRP,U,2)_"' category? "
135 S DIR("?")="Enter YES to completely remove this category and all its items."
136 D ^DIR Q:'Y
137DEL1 ; Ok, go for it ...
138 W !!,"Deleting category items ..."
139 F IFN=0:0 S IFN=$O(^GMPL(125.12,"B",+GMPLGRP,IFN)) Q:IFN'>0 S DA=IFN,DIK="^GMPL(125.12," D ^DIK W "."
140 S DA=+GMPLGRP,DIK="^GMPL(125.11," D ^DIK W "."
141 L -^GMPL(125.11,+GMPLGRP,0) S GMPLGRP=0 K GMPLSAVE W " <done>"
142 D NEWGRP S:+GMPLGRP'>0 VALMBCK="Q"
143 Q
144 ;
145VALGRP(GMPLCAT) ; check all problems in the category for inactive codes
146 ; Input:
147 ; GMPLCAT = ien from file 125.11
148 ;
149 ; Output:
150 ; 1 = category has no problems with inactive codes
151 ; 0 = category has one or more problems with inactive codes
152 ; O^ERR = category is invalid^error message
153 ;
154 I '$G(GMPLCAT) Q "0^No category selected"
155 N PROB,GMPLVALC
156 S GMPLVALC=1,PROB=0
157 F S PROB=$O(^GMPL(125.12,"B",GMPLCAT,PROB)) Q:'PROB!('GMPLVALC) D
158 . N GMPLCOD
159 . S GMPLCOD=$P(^GMPL(125.12,PROB,0),U,5)
160 . Q:'$L(GMPLCOD) ; no code there
161 . I '$$STATCHK^ICDAPIU(GMPLCOD,DT) S GMPLVALC=0
162 . Q
163 Q GMPLVALC
164 ;
165VALLIST(LIST) ;check all categories in list for probs w/ inactive codes
166 ; Input:
167 ; LIST = ien from file 125
168 ;
169 ; Output:
170 ; 1 = list has no problems with inactive codes
171 ; 0 = list has one or more problems with inactive codes
172 ; O^ERR = list is invalid^error message
173 ;
174 N GMPLIEN,GMPLVAL
175 I '$G(LIST) Q 0
176 S GMPLIEN=0,GMPLVAL=1
177 F S GMPLIEN=$O(^GMPL(125.1,"B",LIST,GMPLIEN)) Q:'GMPLIEN!('GMPLVAL) D
178 . N GMPLCAT
179 . S GMPLCAT=$P(^GMPL(125.1,GMPLIEN,0),U,3) I 'GMPLCAT Q
180 . I '$$VALGRP(GMPLCAT) S GMPLVAL=0
181 . Q
182 Q GMPLVAL
183 ;
184ASSIGN ; allow lookup of PROB SEL LIST and assign to users
185 ;
186 N DIC,X,Y,DUOUT,DTOUT,GMPLSLST
187 S DIC="^GMPL(125,",DIC(0)="AEQMZ",DIC("A")="Select LIST NAME: "
188 D ^DIC
189 Q:$D(DTOUT)!($D(DUOUT))
190 Q:Y<0
191 I '$$VALLIST(+Y) D G ASSIGN
192 . W !!,$C(7),"This Selection List contains problems with inactive ICD9 codes associated with"
193 . W !,"them. The codes must be edited and corrected before the list can be assigned to",!,"users.",!!
194 ;
195 S GMPLSLST=+Y
196 D USERS^GMPLBLD3("1")
197 Q
Note: See TracBrowser for help on using the repository browser.