source: FOIAVistA/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXRRPECS.m@ 1446

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

initial load of FOIAVistA 6/30/08 version

File size: 5.9 KB
Line 
1PXRRPECS ;ISL/PKR - Build a list of Person Class entries. ;12/11/96
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**12,147**;Aug 12, 1996
3 ;
4 ;=======================================================================
5PCLASS ;Build a list of person classes.
6 N BELL,IC,INDENT,JC,NOCC,NS,NSPEC,NSUB,OCC,OCCIEN,PCLASS
7 N SELECT,SOCC,SOCCW,SPEC,SPECIEN,SSPEC,SSPECW,SUB,SSUB,TEMP,WC,X,Y
8 ;We will need a DBIA for reading the Person Class file.
9 ;Build a list of the OCCUPATION entries in the Person Class file.
10 S IC=0
11 F S IC=$O(^USC(8932.1,IC)) Q:+IC=0 D
12 . S TEMP=$P(^USC(8932.1,IC,0),U,1)
13 . I $L(TEMP)>0 S OCC($$UPPRCASE^PXRRPECU(TEMP))=TEMP
14 ;
15 ;Count the number of Occupation entries.
16 S NOCC=0
17 S IC=""
18 F S IC=$O(OCC(IC)) Q:IC="" D
19 . S NOCC=NOCC+1
20 ;
21 S BELL=$C(7)
22 ;Set the wildcard to be *.
23 S WC="*"
24 ;NS is NOT SPECIFIED.
25 S NS="NOT SPECIFIED"
26 S INDENT=3
27 S NCL=0
28 K PXRRPECL
29MPROMPT W !,"Select PERSON CLASS (OCCUPATION, SPECIALTY, SUBSPECIALTY)"
30 K DTOUT,DUOUT
31 W !
32NPCLASS ;
33 I NCL'<1 W !!,"Select another PERSON CLASS OCCUPATION"
34 ;Select an occupation.
35NOCC S DIR(0)="FAOU^1:60"
36 S DIR("?")="^D OCCHLP^PXRRPECS"
37 S DIR("??")="^D LISTA^PXRRPECU(.OCC)"
38 S DIR("A")=" Select OCCUPATION (enter "_WC_" for all, return to end selection): "
39 W !
40 D ^DIR
41 K DIR
42 I $D(DIROUT) S DTOUT=1
43 I $D(DTOUT)!$D(DUOUT) Q
44 S SOCC=$$FDME^PXRRPECU(Y,.OCC)
45 I SOCC=-1 W " ??",BELL G NOCC
46 I ($P(SOCC,U,1)="")&(NCL=0) D G MPROMPT
47 . W !,"You must select a person class!"
48 I $P(SOCC,U,1)="" Q
49 I $P(SOCC,U,1)=WC S SOCCW=1
50 E S SOCCW=0
51 ;
52 ;Build a list of iens for SOCC (Selected OCCupation).
53 K OCCIEN
54 K SPEC
55 I ('SOCCW) D
56 . S TEMP=$E($P(SOCC,U,2),1,62)
57 . S IC=0
58 . F S IC=$O(^USC(8932.1,"B",TEMP,IC)) Q:+IC=0 D
59 .. S OCCIEN(IC)=""
60 ;
61 ;Build a list of specialties valid for SOCC.
62 S IC=0
63 F S IC=$O(OCCIEN(IC)) Q:+IC=0 D
64 . S TEMP=$P(^USC(8932.1,IC,0),U,2)
65 . I TEMP="" S TEMP=NS
66 . S SPEC($$UPPRCASE^PXRRPECU(TEMP))=TEMP
67 ;
68 ;Special case for Occupation selected as wildcard.
69 I SOCCW D
70 . S IC=0
71 . F S IC=$O(^USC(8932.1,IC)) Q:+IC=0 D
72 .. S TEMP=$P(^USC(8932.1,IC,0),U,2)
73 .. I TEMP="" S TEMP=NS
74 .. S SPEC($$UPPRCASE^PXRRPECU(TEMP))=TEMP
75 ;
76 ;Count the number of Specialty entries compatible with the selected
77 ;Occupation.
78 S NSPEC=0
79 S IC=0
80 F S IC=$O(SPEC(IC)) Q:IC="" D
81 . S NSPEC=NSPEC+1
82 ;
83 I NSPEC=0 D G NPCLASS
84 . W !,"There are no specialties for:"
85 . W !,?INDENT,"OCCUPATION: ",$P(SOCC,U,1)
86 . S NCL=NCL+1
87 . S PXRRPECL(NCL)=$P(SOCC,U,2)_U_NS_U_NS
88 ;
89 ;Select a specialty.
90 S SSPEC=""
91NSPEC I (NCL>0)&($L(SSPEC)>0) D VERIFY^PXRRPECU
92 S DIR(0)="FAOU^1:50"
93 S DIR("?")="^D SPECHLP^PXRRPECS"
94 S DIR("??")="^D LISTA^PXRRPECU(.SPEC)"
95 S DIR("A")=" Select SPECIALTY (enter "_WC_" for all, return to change OCCUPATION): "
96 W !!,"The currently selected OCCUPATION is:"
97 W !," ",$P(SOCC,U,2)
98 D ^DIR K DIR
99 I $D(DIROUT) S DTOUT=1
100 I $D(DTOUT) Q
101 I $D(DUOUT) G NOCC
102 I $L(Y)=0 G NPCLASS
103 S SSPEC=$$FDME^PXRRPECU(Y,.SPEC)
104 I $P(SSPEC,U,1)="" G NPCLASS
105 I SSPEC=-1 W " ??",BELL G NSPEC
106 I $P(SSPEC,U,1)=WC S SSPECW=1
107 E S SSPECW=0
108 ;
109 ;Build a list of iens for SSPEC (Selected SPECialty). Trim the OCCIEN
110 ;list so it only contains entries valid for SOCC and SSPEC.
111 K SPECIEN
112 K SUB
113 S IC=0
114 F S IC=$O(OCCIEN(IC)) Q:+IC=0 D
115 . S SPECIEN(IC)=OCCIEN(IC)
116 ;
117 ;If SSPEC was selected as the wildcard then we don't need to do
118 ;anything.
119 I ('SSPECW)&('SOCCW) D
120 . S TEMP=$P(SSPEC,U,2)
121 . S IC=0
122 . F S IC=$O(SPECIEN(IC)) Q:+IC=0 D
123 .. I $P(^USC(8932.1,IC,0),U,2)'=TEMP K SPECIEN(IC)
124 ;
125 ;Special case with SOCC=WC and SSPEC'=WC
126 I ('SSPECW)&(SOCCW) D
127 . S TEMP=$P(SSPEC,U,2)
128 . S IC=0
129 . F S IC=$O(^USC(8932.1,IC)) Q:+IC=0 D
130 .. I $P(^USC(8932.1,IC,0),U,2)=TEMP S SPECIEN(IC)=""
131 ;
132 ;Build a list of subspecialties valid for SOCC and SSPEC.
133 S IC=0
134 F S IC=$O(SPECIEN(IC)) Q:+IC=0 D
135 . S TEMP=$P(^USC(8932.1,IC,0),U,3)
136 . I TEMP="" S TEMP=NS
137 . S SUB($$UPPRCASE^PXRRPECU(TEMP))=TEMP
138 ;
139 ;Special case SOCC and SSPEC are wild.
140 I (SSPECW)&(SOCCW) D
141 . S IC=0
142 . F S IC=$O(^USC(8932.1,IC)) Q:+IC=0 D
143 .. S TEMP=$P(^USC(8932.1,IC,0),U,3)
144 .. I TEMP="" S TEMP=NS
145 .. S SUB($$UPPRCASE^PXRRPECU(TEMP))=TEMP
146 ;
147 ;Count the number of entries.
148 S NSUB=0
149 S IC=""
150 F S IC=$O(SUB(IC)) Q:IC="" D
151 . S NSUB=NSUB+1
152 ;
153 I (NSUB=0)!((NSUB=1)&($D(SUB(NS)))) D G NSPEC
154 . W !,"There are no subspecialties for:"
155 . W !,?INDENT,"OCCUPATION: ",$P(SOCC,U,1)
156 . W !,?INDENT,"SPECIALTY: ",$P(SSPEC,U,1)
157 . S NCL=NCL+1
158 . S PXRRPECL(NCL)=$P(SOCC,U,2)_U_$P(SSPEC,U,2)_U_NS
159 ;
160 ;Select a subspecialty.
161NSUB S DIR(0)="FAOU^1:50"
162 S DIR("?")="^D SUBHLP^PXRRPECS"
163 S DIR("??")="^D LISTA^PXRRPECU(.SUB)"
164 S DIR("A")=" Select SUBSPECIALTY (enter "_WC_" for all): "
165 D ^DIR K DIR
166 I $D(DIROUT) S DTOUT=1
167 I $D(DTOUT) Q
168 I $D(DUOUT) G NSPEC
169 I $L(Y)=0 S SSUB=NS_U_NS
170 E S SSUB=$$FDME^PXRRPECU(Y,.SUB)
171 I SSUB=-1 W " ??",BELL G NSUB
172 ;
173 ;Save the selections.
174 S TEMP=$L($P(SOCC,U,1))+$L($P(SSPEC,U,1))+$L($P(SSUB,U,1))
175 I TEMP=0 Q
176 I TEMP>0 D
177 . S NCL=NCL+1
178 . S PXRRPECL(NCL)=$P(SOCC,U,2)_U_$P(SSPEC,U,2)_U_$P(SSUB,U,2)
179 I $D(DUOUT) G PCLASS
180 I (NCL=0)&($D(DIRUT)!$D(DUOUT)) Q
181 I (NCL=0) W !,"You must select a PERSON CLASS!" G PCLASS
182 G NSPEC
183 ;
184 ;=======================================================================
185OCCHLP ;Help for occupation input.
186 N PROMPT
187 W !!,"Answer with an OCCUPATION, note ",WC," matches all OCCUPATIONS"
188 S PROMPT="Do you want the entire "_NOCC_"-entry occupation list? "
189 I $$GETYORN^PXRRPECU(PROMPT) D LISTA^PXRRPECU(.OCC)
190 Q
191 ;
192 ;=======================================================================
193SPECHLP ;Help for specialty input.
194 N PROMPT
195 W !!,"Answer with a SPECIALTY, note ",WC," matches all SPECIALTIES"
196 S PROMPT="Do you want the entire "_NSPEC_"-entry specialty list? "
197 I $$GETYORN^PXRRPECU(PROMPT) D LISTA^PXRRPECU(.SPEC)
198 Q
199 ;
200 ;=======================================================================
201SUBHLP ;Help for subspecialty input.
202 N PROMPT
203 W !!,"Answer with a SUBSPECIALTY, note ",WC," matches all SUBSPECIALTIES"
204 S PROMPT="Do you want the entire "_NSUB_"-entry subspecialty list? "
205 I $$GETYORN^PXRRPECU(PROMPT) D LISTA^PXRRPECU(.SUB)
206 Q
207 ;
Note: See TracBrowser for help on using the repository browser.