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

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

initial load of WorldVistAEHR
File size: 6.9 KB
Line 
1PXBGPRV ;ISL/JVS,ESW - GATHER PROVIDERS ; 12/5/02 11:35am
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,11,108,186**;Aug 12, 1996;Build 3
3 ;
4PRV(VISIT,PXBSKY,PXBKY,PXBSAM,PXBCNT,PRVDR,FPRI) ;--Gather the entries in the V PROVIDER file
5 ;
6 ;Output:
7 ; PXBSKY(PXBC,IEN)=PRVI
8 ; PXBKY(NAME,PXBC)=NAME^P^TYPE^PRVI
9 ; PXBSAM(PXBC)=NAME^P^TYPE^PRVI
10 ; PRVDR("PRIMARY")=NAME^IEN^PRVI
11 ; PXBCNT
12 ; FPRI
13 ;where:
14 ; PXBC - sequence in an order of providers name
15 ; IEN - of ^AUPNVPRV(
16 ; NAME - provider's name (LAST,FIRST...)
17 ; P - PRIMARY or SECONDARY
18 ; PRVI - IEN of ^VA(200,
19 ; PXBCNT - provider count
20 ; FPRI:
21 ; 0 - Primary not selected
22 ; 1 - Primary selected
23 ;
24 N IEN,QUANTITY,PROVIDER,PRIMARY,PRV,GROUP,PXBC
25 N DIC,DR,DA,DIQ,PRVI,TYPE
26 ;
27 K ^TMP("PXBU",$J),PRV,PXBKY,VAUGHN,PXBSAM,PXBSKY,PXBCNT,PXBPRV,FPRI
28 K PRVDR
29 S FPRI=""
30 ; create an array of current providers without duplicates, with their
31 ; ^(0) node as a value
32 I $D(^AUPNVPRV("AD",VISIT)) D
33 .D GETPRV^PXAPIOE(VISIT,"^TMP(""PXBU"",$J,""PRV"")")
34 ;
35A ;--Set array with PROVIDERS
36 ;
37 I $G(^TMP("PXBU",$J,"PRV")) D
38 .S IEN=0 F S IEN=$O(^TMP("PXBU",$J,"PRV",IEN)) Q:IEN'>0 D
39 ..S PRIMARY=$S($P(^(IEN),U,4)="P":"PRIMARY",1:"SECONDARY")
40 ..S PRVI=+^(IEN),TYPEI=$P(^(IEN),U,6)
41 ..S DIC=200,DIC1=DIC,DR=.01,DA=PRVI,DIQ="PRVN" D EN^DIQ1 D
42 ...S PRV=PRVN(DIC1,DA,DR)
43 ..S FPRI=FPRI_$E(PRIMARY,1,3) ;-Creating Flag for Primary prompt
44 ..S TYPE=$$OCCUP("","","",2,TYPEI) D
45 ...N Y,DATE
46 ...S Y=+$P($G(^AUPNVSIT(VISIT,0)),U) X ^DD("DD") S DATE=$P(Y,"@",1)
47 ...I TYPEI="" S TYPE=$$GET^XUA4A72(PRVI,+$P($P($G(^AUPNVSIT(VISIT,0)),U),"."))
48 ...I +TYPE=-2 S TYPE="*** CLASS not 'ACTIVE' on "_DATE_"***"
49 ...I +TYPE=-1 S TYPE=""
50 ...;I +TYPE>0 S TYPE="**** DELETE and RE-ENTER PROVIDER****"
51 ...I +TYPE>0 S TYPE=""
52 ..S GROUP=PRV_U_PRIMARY_U_TYPE_U_PRVI
53 ..I PRIMARY["PRI" S PRVDR("PRIMARY")=PRV_U_IEN_U_PRVI
54 ..S PRV(PRV,IEN)=GROUP
55 K ^TMP("PXBU",$J,"PRV")
56 ;
57B ;--Add line numbers
58 ;create local arrays with data from existing providers
59 I $D(PRV) D
60 .S PXBC=0,PRV="" F S PRV=$O(PRV(PRV)) Q:PRV="" D
61 ..S IEN=0 F S IEN=$O(PRV(PRV,IEN)) Q:IEN="" S PXBC=PXBC+1 D
62 ...S PXBKY(PRV,PXBC)=$G(PRV(PRV,IEN)),PXBSAM(PXBC)=$G(PRV(PRV,IEN))
63 ...S PXBSKY(PXBC,IEN)=$P(PRV(PRV,IEN),U,4)
64 ...K PRV(PRV,IEN)
65FINISH ;--Finish up some variables
66 S:FPRI'["PRI" FPRI=0 S:FPRI["PRI" FPRI=1
67 ;FPRI=0 Then there is no Primary Selected yet
68EXIT ;--set a providers count
69 S PXBCNT=+$G(PXBC)
70 Q
71 ;
72OCCUP(IEN,DATE,CODE,RETURN,CLASSIEN) ;--FORMAT PERSON CLASS TO DISPLAY
73 ; IEN = Provider pointer to file# 200
74 ; DATE = Date of occurrence of service
75 ; CODE = Person class Code (if already known)
76 ; **(Required step) If you use code leave IEN and DATE Blank
77 ; RETURN = (Required) Flag to decide what format you want the
78 ; return value.
79 ; CLASSIEN = Ien of entry in the PERSON CLASS file#8932.1 If the Ien
80 ; was saved this parameter could be sent in instead of CODE.
81 ;
82 ; 1 = IEN^OCCUPATION^SPECIALITY^SUBSPECIALITY^STATUS^DATE INACTIVATED^VA CODE
83 ; 2 = Short Description
84 ; 3 = Short Description^VA CODE
85 ; *** If only CODE and RETURN = 1 There is no value or other
86 ; value in the STATUS and DATE INACTIVATED fields.
87 ;
88 ; Output:
89 ; -1 "no comment" function call to person class couldn't find
90 ; a class for that person.
91 ; -1^COMMENT This function is called incorrectly
92 ; -2 "no comment" There is no ACTIVE person class for provider
93 ; based on the date provided.
94 ;
95 N OCC,SPE,SUB,ENTRY,DIS,OCCL,TYPE,VACODE,ANS
96 ;--VALIDATE
97 I (+$G(IEN)'>0)&($L(IEN)>0) Q -1_"^INVALID PERSON IEN"
98 I '$G(IEN),'$G(DATE),$G(CODE)="",'$G(RETURN),'$G(CLASSIEN) Q -1_"^NO PARAMETERS"
99 I '$G(IEN),'$G(DATE),$G(CODE)="",$G(RETURN),'$G(CLASSIEN) Q -1_"^NO PARAMETERS"
100 I '$G(RETURN) Q -1_"^NO RETURN PARAMETER (Required)"
101 I $G(RETURN)]"",(RETURN'<4!(RETURN'>0)) Q -1_"^RETURN MUST BE 1,2,or 3"
102 I DATE]"",+DATE'>0 Q -1_"^INVALID FILEMAN DATE"
103 I $G(IEN) Q:'$D(^VA(200,$G(IEN))) -1_"^NO SUCH IEN IN FILE# 200"
104 I $G(IEN),$G(DATE) D I $G(RETURN)=1 Q TYPE
105 .S TYPE=$$GET^XUA4A72(IEN,$P(DATE,".")),VACODE=$P(TYPE,U,7)
106 I $G(IEN),$G(DATE),+TYPE<0 Q TYPE
107 ;
108 ;---CONVERT IEN TO CODE
109 I $G(CLASSIEN) S CODE=$$IEN2CODE^XUA4A72(CLASSIEN)
110 ;
111 I $G(CODE)]"",'$G(IEN),'$G(DATE) S TYPE=$O(^USC(8932.1,"F",$G(CODE),0)),VACODE=CODE I $G(RETURN)=1 S ANS=TYPE_U_$G(^USC(8932.1,TYPE,0)) Q ANS
112 S ENTRY=$G(^USC(8932.1,+TYPE,0))
113OCC ;---OCCUPATION
114 S OCCL=$P(ENTRY,U)
115 S OCC=$P($P(ENTRY,U)," ",1)
116 I OCCL["Physicians (M.D" S OCC="Physician"
117 I OCCL["Physician Assistant" S OCC=OCCL
118 I OCCL["Speech, Language" S OCC="Language"
119 I OCCL["Technologists" S OCC="Technical"
120 I OCCL["Eye and Vision" S OCC="Ophthalmic"
121 I OCCL["Respiratory, Rehab" S OCC="Therapist"
122 I OCCL["Podiatric" S OCC="Podiatry"
123 ;
124SPE ;--SPECIALITY
125 S SPEL=$P(ENTRY,U,2)
126 S SPE=$P(ENTRY,U,2)
127 I SPEL["Registered Nurse" S SPE="R.N."
128 I SPEL["Dentist" S SPE="Dentist"
129 I SPEL["Clinical Services" S SPE="Clinical"
130 I SPEL["Non-R.N.s" S SPE="Non R.N."
131 I SPEL["Radiologic Sciences" S SPE="Radiology"
132 I SPEL["Clinical Path" S SPE=""
133 I SPEL["Physical Therap" S SPE="P.T."
134 I SPEL["Obstetrics and Gynecology" S SPE="Ob. & Gyn."
135 I SPEL["iatry and Neur" S SPE="Psyc & Neuro"
136 I SPEL["Clinical Specialist" S SPE="Clinical"
137 I SPEL["Registered Dietitian" S SPE="R. Dietitian"
138 I SPEL["Rehabilitation Prac" S SPE="Rehabilitation"
139 I OCC["Physician"&(SPE["Internal Medicine") S SPE="Internist"
140 ;
141SUB ;--SUBSPECIALITY
142 S SUBL=$P(ENTRY,U,3)
143 S SUB=$P(ENTRY,U,3)
144 I SUB["Counselor"&(SPE["Counselor") S SPE=""
145 I SUB["Therapist"&(SPE["Therapist") S SPE=""
146 I SUB["Nurse"&(SPE["Nurse") S SPE=""
147 I SUB["Pediatric"&(SPE["Pediatric") S SPE=""
148 I SUB["Psychiatry"&(SPE["Psychiatry") S SPE=""
149 I SUB["Podiatri"&(SPE["Podiatri") S SPE=""
150 I SUB["Clinical and Laboratory Immunology" S SUB="Clin & Lab Immunology"
151 I SUB["Clinical & Laboratory Immunology" S SUB="Clin & Lab Immunology"
152 I SUB["cine-Envir" S SUB="Occ & Environmental"
153 I SUB["Child and Adolescent Psyc" S SUB="Pediatric Mental Health"
154 I SUB["ist in Meta" S SUB="Metabolic"
155 I SUB["ist in Pedia" S SUB="Pediatric"
156 I SUB["ist in Renal" S SUB="Renal"
157 I SUB["tion Intern" S SUB="Intern"
158 I SUB["tion Coordin" S SUB="Coordinator"
159 I SUB["tion Counselor" S SUB="Counselor"
160 I SUB["for the Blind" S SUB="Orientation for Blind"
161 I SUB["Dosimetrist" S SUB="Planning, Dosimetrist"
162 I SPEL["Respiratory Care Pr"&(SUB'="") S SPE=""
163 ;
164 ;--CALCULATE THE BEST DISPLAY
165 S DISL=OCCL_"-"_SPEL_"-"_SUBL
166 S DIS=OCC_"/"_SPE_"/"_SUB
167 I SUB[SPE S DIS=OCC_"/"_SUB
168 I SPE="" S DIS=OCC_"/"_SUB
169 I SUB="" S DIS=OCC_"/"_SPE
170AND I $L(DIS," and ")>1 D
171 .N I F I=1:1:$L(DIS," ") I $P(DIS," ",I)="and" S $P(DIS," ",I)="&"
172 I $L(DIS," and ")>1 G AND
173 ;Q $E(DIS,1,40)_" "_$L(DIS)
174 ;Q $E(DIS,1,40)_"***"_OCCL
175 ;Q SPE_" *** "_SPEL
176 ;Q SUB_" *** "_SUBL
177 ;Q DISL_"~"_DIS
178 ;Q ""_"~"_DIS
179 I $G(RETURN)=2 Q DIS
180 I $G(RETURN)=3 Q DIS_U_VACODE
181 Q -1_"^SOMETHING BAD WRONG_SHOULDN'T BE HERE"
Note: See TracBrowser for help on using the repository browser.