source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXRRPECU.m@ 1801

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

initial load of WorldVistAEHR

File size: 5.5 KB
Line 
1PXRRPECU ;ISL/PKR - Utilities for dealing with the Person Class file. ;4/3/97
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**12,31**;Aug 12, 1996
3 ;
4 ;=======================================================================
5ABBRV(VACODE) ;Given a VACODE get the full Person Class entry and return an
6 ;abbreviation for it.
7 N ABBRV,MAXLEN,MAXLENP3,OCC,PCLASS,SPEC,SUB
8 ;If there is no VACODE then return Unknown.
9 I $L(VACODE)'>0 Q "Unknown"
10 ;
11 S MAXLEN=20
12 S MAXLENP3=MAXLEN+3
13 I $L(VACODE,U)=3 S PCLASS=U_VACODE
14 E S PCLASS=$$OCCUP^PXBGPRV("","",VACODE,1,"")
15 ;
16 S OCC=$P(PCLASS,U,2)
17 I $L(OCC)>MAXLENP3 S OCC=$E(OCC,1,MAXLEN)_"..."
18 S ABBRV=OCC
19 ;
20 S SPEC=$P(PCLASS,U,3)
21 I $L(SPEC)>MAXLENP3 S SPEC=$E(SPEC,1,MAXLEN)_"..."
22 I $L(SPEC)>0 S ABBRV=ABBRV_"+"_SPEC
23 S SUB=$P(PCLASS,U,4)
24 I $L(SUB)>MAXLENP3 S SUB=$E(SUB,1,MAXLEN)_"..."
25 I $L(SUB)>0 S ABBRV=ABBRV_"+"_SUB
26 Q ABBRV
27 ;
28 ;=======================================================================
29ALPHA(PCLASS) ;Given a person class of the form IEN_U_Occupation_U_Specialty
30 ;_U_^Subspecialty return an abbreviation useful for alphabetizing.
31 N T1,TEMP
32 ;If there is no person class return Unknown.
33 I +$P(PCLASS,U,1)'>0 Q "Unknown"
34 S TEMP=$E($P(PCLASS,U,2),1,4)
35 S T1=$E($P(PCLASS,U,3),1,4)
36 I $L(T1)'>0 S T1="+"
37 S TEMP=TEMP_T1
38 S T1=$E($P(PCLASS,U,4),1,4)
39 I $L(T1)'>0 S T1="+"
40 S TEMP=TEMP_T1
41 S TEMP=TEMP_U_$P(PCLASS,U,7)
42 Q TEMP
43 ;
44 ;=======================================================================
45FDME(INP,ARRAY) ;Find and display the entries matching the input and get a selection.
46 N DIR,IC,JC,LINP,RET,SA,X,Y
47 ;Check for the special cases first.
48 ;The null selection.
49 I INP="" Q INP
50 ;The wildcard selection.
51 I INP=WC Q WC_U_WC
52 ;An exact match.
53 I $D(ARRAY(INP)) Q INP_U_ARRAY(INP)
54 ;
55 S RET=-1
56 S INP=$$UPPRCASE(INP)
57 S LINP=$L(INP)
58 S IC=INP
59 S JC=0
60 F S IC=$O(ARRAY(IC)) Q:(INP'=$E(IC,1,LINP)) D
61 . S JC=JC+1
62 . S SA(JC)=IC_U_ARRAY(IC)
63 I JC=1 W " ",$P(SA(1),U,1) Q SA(1)
64 I JC>1 D
65 . F IC=1:1:JC D
66 .. W !,IC,?INDENT,$P(SA(IC),U,1)
67 . S DIR(0)="NAO^1:"_JC
68 . S DIR("A")="Choose 1-"_JC_": "
69 . W !
70 . D ^DIR
71 . I +Y>0 S RET=SA(+Y)
72 Q RET
73 ;
74 ;=======================================================================
75GETYORN(PROMPT) ;Get a yes or no answer, return true (yes) or false (no).
76 N DIR,X,Y
77 S DIR(0)="YAO"
78 I $D(PROMPT) S DIR("A")=PROMPT
79 D ^DIR
80 Q Y
81 ;
82 ;=======================================================================
83LISTA(ARRAY) ;List all the elements of ARRAY.
84 N IC,DONE
85 K SELECT
86 S $Y=0
87 S DONE=0
88 W !,"Choose from:"
89 S IC=""
90 F S IC=$O(ARRAY(IC)) Q:(IC="")!(DONE) D
91 . W !,?INDENT,IC
92 . I $Y>(IOSL-3) D PAGE(.ARRAY)
93 I $D(SELECT) D
94 . I SELECT'=-1 D
95 .. ;S SSPEC=SELECT
96 .. S DIR("B")=$P(SELECT,U,1)
97 Q
98 ;
99 ;=======================================================================
100MATCH(PCLASS) ;Return true if PCLASS is in the PERSON CLASS list, PXXRPECL.
101 N CLASSIEN,IC,LOCC,LSPEC,LSUB,MATCH,MOCC,MSPEC,MSUB
102 N NS,OCC,SPEC,SUB,WC
103 ;If PCLASS is less than 0 then no person class was returned.
104 ;Therefore there cannot be a match.
105 I +PCLASS<0 Q 0
106 ;
107 S NS="NOT SPECIFIED"
108 S WC="*"
109 S CLASSIEN=$P(PCLASS,U,1)
110 ;OCCUP^PXBGPRV returns negative numbers in first piece if there was no
111 ;person class. In this case the only match will be for the wildcard.
112 I +CLASSIEN'>0 D
113 . S (OCC,SPEC,SUB)=WC
114 E D
115 . S OCC=$P(PCLASS,U,2)
116 . S SPEC=$P(PCLASS,U,3)
117 . S SUB=$P(PCLASS,U,4)
118 I $L(SPEC)=0 S SPEC=NS
119 I $L(SUB)=0 S SUB=NS
120 ;
121 S MATCH=0
122 F IC=1:1:NCL Q:MATCH D
123 . S LOCC=$P(PXRRPECL(IC),U,1)
124 . I (LOCC'=OCC)&(LOCC'=WC) Q
125 . S LSPEC=$P(PXRRPECL(IC),U,2)
126 . I (LSPEC'=SPEC)&(LSPEC'=WC) Q
127 . S LSUB=$P(PXRRPECL(IC),U,3)
128 . I (LSUB'=SUB)&(LSUB'=WC) Q
129 .;If we got to here we have a match.
130 . S $P(PXRRPECL(IC),U,4)="M"
131 . S MATCH=1
132 ;
133 Q MATCH
134 ;
135 ;=======================================================================
136NXREF(XREF,STRING) ;Return the number of elements for the STRING and cross-ref pair.
137 N IC,JC
138 S (IC,JC)=0
139 F S IC=$O(^USC(8932.1,XREF,STRING,IC)) Q:+IC=0 D
140 . S JC=JC+1
141 Q JC
142 ;
143 ;=======================================================================
144PAGE(ARRAY) ;Page breaking with optional return of selection.
145 N DIR,X,Y
146 S DIR(0)="FAOU^1:60"
147 S DIR("A")="Enter Return to continue, your selection, or '^' to exit: "
148 W !
149 D ^DIR K DIR
150 I $D(DUOUT)!($D(DTOUT)) S DONE=1 Q
151 I Y="" W:$D(IOF) @IOF
152 E D Q
153 . S SELECT=$$FDME(Y,.ARRAY)
154 . S DONE=1
155 K DTOUT,DUOUT
156 Q
157 ;
158 ;=======================================================================
159PCLLIST(NEWPIEN,BDT,EDT,LIST) ;Build a list of all the person classes for the
160 ;provider NEWPIEN in the date range BDT to EDT. Return the total
161 ;number.
162 N IC,PCLASS,TEMP,TLIST,TOTAL
163 K LIST
164 S TOTAL=0
165 F IC=BDT:1:EDT D
166 . S PCLASS=$$GET^XUA4A72(NEWPIEN,IC)
167 . I PCLASS>0 D
168 .. S TEMP=$$ALPHA(PCLASS)
169 . E S TEMP="Unknown"
170 . S TLIST(TEMP)=""
171 ;Count and return the unique entries.
172 S IC=""
173 F S IC=$O(TLIST(IC)) Q:IC="" D
174 . S TOTAL=TOTAL+1
175 . S LIST(TOTAL)=IC
176 Q TOTAL
177 ;
178 ;=======================================================================
179UPPRCASE(STRING) ;Convert STRING to uppercase and return it.
180 Q $TR(STRING,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
181 ;
182 ;=======================================================================
183VERIFY ;Have the user verify the most recent Person Class selection.
184 N KEEP,PROMPT
185 W !!,"Your Person Class Selection was:"
186 W !,?INDENT,"OCCUPATION: ",$P(PXRRPECL(NCL),U,1)
187 W !,?INDENT,"SPECIALTY: ",$P(PXRRPECL(NCL),U,2)
188 W !,?INDENT,"SUBSPECIALTY: ",$P(PXRRPECL(NCL),U,3)
189 W !
190 S PROMPT="Is this selection correct? "
191 S KEEP=$$GETYORN(PROMPT)
192 I 'KEEP D
193 . K PXRRPECL(NCL)
194 . S NCL=NCL-1
195 Q
Note: See TracBrowser for help on using the repository browser.