source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXDSSD.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: 7.1 KB
Line 
1ECXDSSD ;ALB/JAP - Derive DSS Department code ;July 16, 1998
2 ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
3 ;
4DERIVE(ECXSVC,ECXPUNIT,ECXDIV,ECXSUF) ;entry point for extrinsic function
5 ; input
6 ; ECXSVC = null or pointer to file #730; required
7 ; ECXPUNIT = null or pointer to file #729; required
8 ; ECXDIV = null or pointer to file #727.3; required
9 ; ECXSUF = null or character string; optional
10 ; output
11 ; DSSDEPT = dss department code as ABBCxxx or null
12 ; A=DSS CODE from file (#730)
13 ; BB=DSS PRODUCTION UNIT CODE from file (#729)
14 ; C=DSS DIVISION IDENTIFIER from file (#727.3)
15 ; xxx=suffix of not more than three characters (optional)
16 ;
17 N DSSDEPT
18 S DSSDEPT=""
19 Q:'$D(ECXSVC) DSSDEPT Q:'$D(ECXPUNIT) DSSDEPT Q:'$D(ECXDIV) DSSDEPT
20 D GETDIV(.ECXDIV)
21 I ECXDIV="" Q DSSDEPT
22 D GETSVC(.ECXSVC)
23 I ECXSVC="" Q DSSDEPT
24 D GETPUNIT(.ECXPUNIT)
25 I ECXPUNIT="" Q DSSDEPT
26 S DSSDEPT=ECXSVC_ECXPUNIT_ECXDIV
27 ;if variable ecxsuf does not exist, then do nothing
28 ;if variable ecxsuf is null, then assume user interaction for entry
29 ;if variable suffix is a character string, then assume no user interaction; validate ecxsuf
30 I $D(ECXSUF) D
31 .D GETSUF(.ECXSUF)
32 .S DSSDEPT=DSSDEPT_ECXSUF
33 Q DSSDEPT
34 ;
35GETDIV(ECXDIV) ;get division portion of dss dept code
36 ; input
37 ; ECXDIV = pointer to file #40.8 or null; required; passed by reference
38 ; output
39 ; ECXDIV = dss division identifier or null
40 N ECX,USER,DIC,DR,DIQ,DA,X,Y,DTOUT,DUOUT,JJ,SS
41 S USER=0
42 I ECXDIV="" D Q:$D(DTOUT)!($D(DUOUT))!(+Y<1)
43 .W !!
44 .S USER=1
45 .S DIC(0)="AEMQZ",DIC="^ECX(727.3," D ^DIC
46 .S:+Y>0 ECXDIV=+Y Q
47 S DIC="^ECX(727.3,",DR="1;",DIQ(0)="E",DIQ="ECX",DA=ECXDIV
48 D EN^DIQ1
49 S ECXDIV=$G(ECX(727.3,ECXDIV,1,"E"))
50 I ECXDIV="",USER=1 D
51 .W !!,"The selected division does not yet have a"
52 .W !,"DSS Identifier code defined.",!
53 .W !,"Use the Enter/Edit DSS Division Identifier option"
54 .W !,"to associate a DSS identifier with this division.",!
55 .I $E(IOST)="C" D
56 ..S SS=22-$Y F JJ=1:1:SS W !
57 ..S DIR(0)="E" W ! D ^DIR K DIR W !
58 Q
59 ;
60GETSVC(ECXSVC) ;get service portion of dss dept code
61 ; input
62 ; ECXSVC = pointer to file #730 or null; required; passed by reference
63 ; output
64 ; ECXSVC = dss service code or null
65 N ECX,USER,DIC,DR,DIQ,X,Y,JJ,SS,DA,DTOUT,DUOUT
66 S USER=0
67 I ECXSVC="" D Q:$D(DTOUT)!($D(DUOUT))!(+Y<1)
68 .W !!
69 .S USER=1
70 .S DIC(0)="AEMQZ",DIC="^ECC(730," D ^DIC
71 .S:+Y>0 ECXSVC=+Y
72 S DIC="^ECC(730,",DR="3;",DIQ(0)="E",DIQ="ECX",DA=ECXSVC
73 D EN^DIQ1
74 S ECXSVC=$G(ECX(730,ECXSVC,3,"E"))
75 I ECXSVC="",USER=1 D
76 .W !!,"The selected National Service does not have a"
77 .W !,"DSS Clinical Service code defined.",!
78 .W !,"It cannot be used in a DSS Department code.",!
79 .I $E(IOST)="C" D
80 ..S SS=22-$Y F JJ=1:1:SS W !
81 ..S DIR(0)="E" W ! D ^DIR K DIR W !
82 Q
83 ;
84GETPUNIT(ECXPUNIT) ;get production unit portion of dss dept code
85 ; input
86 ; ECXPUNIT = pointer to file #729 or null; required; passed by reference
87 ; output
88 ; ECXPUNIT = dss production unit code or null
89 N ECX,DIC,DR,DIQ,X,Y,DTOUT,DUOUT,DA
90 I ECXPUNIT="" D Q:$D(DTOUT)!($D(DUOUT))!(+Y<1)
91 .W !!
92 .S DIC(0)="AEMQZ",DIC="^ECX(729," D ^DIC
93 .S:+Y>0 ECXPUNIT=+Y
94 S DIC="^ECX(729,",DR=".01;",DIQ(0)="E",DIQ="ECX",DA=ECXPUNIT
95 D EN^DIQ1
96 S ECXPUNIT=$G(ECX(729,ECXPUNIT,.01,"E"))
97 Q
98 ;
99GETSUF(ECXSUF) ;get suffix portion of dss dept code
100 ; input
101 ; ECXSUF = character string or null; required; passed by reference
102 ; output
103 ; ECXSUF = character string or null;
104 ; input character string will be returned as null
105 N USER,AGAIN,LEN,ZERO,OUT,DIR,DIRUT,DTOUT,DUOUT,X,Y
106 ;ask user for input only if ecxsuf="", otherwise assume no user interaction
107 ;variable user acts as a flag --> if =1, then assume user interaction
108 S USER=0 S:ECXSUF="" USER=1,AGAIN=0
109 ;variable again acts as a flag --> if =1, don't ask user if he wants to enter suffix
110 D SUF2
111 Q
112SUF2 ;ask user for input if necessary, then validate variable ecxsuf
113 I USER=1 D
114 .I AGAIN=0 D Q:$D(DIRUT)!(Y=0)
115 ..W !!
116 ..S DIR(0)="YA",DIR("A")="Do you want to enter a suffix? ",DIR("B")="NO" K X,Y
117 ..D ^DIR K DIR
118 .W !!
119 .S AGAIN=0
120 .S DIR(0)="FA^1:3",DIR("A")="Enter suffix: " K X,Y
121 .D ^DIR K DIR
122 .Q:$D(DIRUT) Q:(X="^")&(Y="^")
123 .S ECXSUF=Y,LEN=$L(ECXSUF)
124 .I ECXSUF["-" D
125 ..I $L(ECXSUF)=1 W !!,"Invalid ...try again." S ECXSUF="",AGAIN=1 Q
126 ..I $E(ECXSUF,1)'="-" D Q
127 ...W !!,"The hyphen character < - > is only allowed as the"
128 ...W !!,"1st character in the suffix.",!
129 ...W !,"Try again...",!
130 ...S ECXSUF="",AGAIN=1
131 ..W !!,"The hyphen character < - > should not be used unless this"
132 ..W !,"DSS Department code was previously established in DSS/Austin."
133 ..W !
134 ..S DIR(0)="YA",DIR("A")="Do you want to remove the hyphen? ",DIR("B")="YES" K X,Y
135 ..D ^DIR K DIR
136 ..S:($D(DIRUT))!(Y=1) ECXSUF="" S:(Y=1) AGAIN=1
137 .Q:AGAIN=1
138 .S ZERO=0
139 .F I=1:1:LEN S X=$E(ECXSUF,I) D Q:AGAIN=1
140 ..Q:X="-"&(I=1)
141 ..I X?1P D Q:AGAIN=1
142 ...W !!,"There is an invalid punctuation character < "_X_" > in the suffix.",!
143 ...W !,"Try again...",!
144 ...S ECXSUF="",AGAIN=1
145 ..I X?1L D Q:AGAIN=1
146 ...W !!,"There is an invalid lowercase character < "_X_" > in the suffix.",!
147 ...W !,"Try again...",!
148 ...S ECXSUF="",AGAIN=1
149 ..S:X="0" ZERO=ZERO+0 S:X'="0" ZERO=ZERO+1
150 .Q:AGAIN=1
151 .I ZERO=0 D
152 ..W !!,"There are too many zeroes in the suffix.",!
153 ..W !,"Try again...",!
154 ..S ECXSUF="",AGAIN=1
155 I USER=1,AGAIN=1 G SUF2
156 ;no user interaction; validate ecxsuf
157 I USER=0,ECXSUF]"" D
158 .S (ZERO,OUT)=0
159 .S LEN=$L(ECXSUF) I LEN>3 S ECXSUF="" Q
160 .F I=1:1:LEN S X=$E(ECXSUF,I) D Q:OUT=1
161 ..I X="-",I'=1 S ECXSUF="",OUT=1
162 ..I X?1P,X'="-" S ECXSUF="",OUT=1
163 ..I X?1L S ECXSUF="",OUT=1
164 ..S:X="0" ZERO=ZERO+0 S:X'="0" ZERO=ZERO+1
165 .I ZERO=0 S ECXSUF=""
166 Q
167 ;
168DECODE ;allow user to decode a dss department code
169 N CODE,DESC,OUT,DIR,DIRUT,DTOUT,DUOUT,X,Y
170 W !!,"You may enter a DSS Department as 'ABBC' (no suffix)."
171 W !,"The code will be 'translated' into a description and displayed.",!!
172 S OUT=0
173 F D Q:OUT=1 Q:$D(DIRUT)
174 .S DIR(0)="FA^4:4",DIR("A")="Enter a DSS Department code: " K X,Y
175 .D ^DIR K DIR
176 .Q:$D(DIRUT) Q:(X="^")&(Y="^")
177 .S CODE=Y D REVERSE(CODE,.DESC)
178 .W !
179 .W !?5,"Service ",?20,"<"_$E(CODE,1)_"> = "_$P(DESC,U,1)
180 .W !?5,"Prod. Unit ",?20,"<"_$E(CODE,2,3)_"> = "_$P(DESC,U,2)
181 .W !?5,"Division ",?20,"<"_$E(CODE,4)_"> = "_$P(DESC,U,3)
182 .W !
183 .S DIR(0)="YA",DIR("A")="Another one? ",DIR("B")="YES" K X,Y
184 .D ^DIR K DIR
185 .I Y=0 S OUT=1
186 Q
187 ;
188REVERSE(ECXDEPT,ECXDESC) ;get dss dept code description
189 ; input
190 ; ECXDEPT = dss dept code as ABBCxxx; required
191 ; output
192 ; ECXDESC = code description; passed by reference
193 ; service_name^prod_unit_long_desc^division_name/station number
194 ; note: if suffix (xxx) is present, it is ignored because free text
195 N SVC,PUNIT,DIV
196 Q:$L(ECXDEPT)<4
197 S SVC=$E(ECXDEPT,1),PUNIT=$E(ECXDEPT,2,3),DIV=$E(ECXDEPT,4)
198 K X,ECXERR S X=$$FIND1^DIC(730,,"X",SVC,"C",,"ECXERR")
199 S SVC=$S(X>0:$P(^ECC(730,X,0),U,1),X=0:"Not found",X="":"Error",1:"")
200 K X,ECXERR S X=$$FIND1^DIC(729,,"X",PUNIT,"B",,"ECXERR")
201 S PUNIT=$S(X>0:$P(^ECX(729,X,0),U,3),X=0:"Not found",X="":"Error",1:"")
202 K X,ECXERR S X=$$FIND1^DIC(727.3,,"X",DIV,"C",,"ECXERR")
203 S DIV=$S(X>0:$P(^DG(40.8,X,0),U,1)_"/"_$P(^(0),U,2),X=0:"Not found",X="":"Error",1:"")
204 S ECXDESC=SVC_U_PUNIT_U_DIV
205 Q
Note: See TracBrowser for help on using the repository browser.