- PXBGPRV ;ISL/JVS,ESW - GATHER PROVIDERS ;11/22/2019
- ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,11,108,186,220,211**;Aug 12, 1996;Build 454
- ;
- PRV(VISIT,PXBSKY,PXBKY,PXBSAM,PXBCNT,PRVDR,FPRI) ;--Gather the entries in the V PROVIDER file
- ;
- ;Output:
- ; PXBSKY(PXBC,IEN)=PRVI
- ; PXBKY(NAME,PXBC)=NAME^P^TYPE^PRVI
- ; PXBSAM(PXBC)=NAME^P^TYPE^PRVI
- ; PRVDR("PRIMARY")=NAME^IEN^PRVI
- ; PXBCNT
- ; FPRI
- ;where:
- ; PXBC - sequence in an order of providers name
- ; IEN - of ^AUPNVPRV(
- ; NAME - provider's name (LAST,FIRST...)
- ; P - PRIMARY or SECONDARY
- ; PRVI - IEN of ^VA(200,
- ; PXBCNT - provider count
- ; FPRI:
- ; 0 - Primary not selected
- ; 1 - Primary selected
- ;
- N IEN,QUANTITY,PROVIDER,PRIMARY,PRV,PRVN,GROUP,PXBC
- N DIC,DR,DA,DIQ,PRVI,TYPE,TYPEI
- ;
- K ^TMP("PXBU",$J),PRV,PXBKY,VAUGHN,PXBSAM,PXBSKY,PXBCNT,PXBPRV,FPRI
- K PRVDR
- S FPRI=""
- ; create an array of current providers without duplicates, with their
- ; ^(0) node as a value
- I $D(^AUPNVPRV("AD",VISIT)) D
- .D GETPRV^PXAPIOE(VISIT,"^TMP(""PXBU"",$J,""PRV"")")
- ;
- A ;--Set array with PROVIDERS
- ;
- I $G(^TMP("PXBU",$J,"PRV")) D
- .S IEN=0 F S IEN=$O(^TMP("PXBU",$J,"PRV",IEN)) Q:IEN'>0 D
- ..S PRIMARY=$S($P(^(IEN),U,4)="P":"PRIMARY",1:"SECONDARY")
- ..S PRVI=+^(IEN),TYPEI=$P(^(IEN),U,6)
- ..S DIC=200,DIC1=DIC,DR=.01,DA=PRVI,DIQ="PRVN" D EN^DIQ1 D
- ...S PRV=PRVN(DIC1,DA,DR)
- ..S FPRI=FPRI_$E(PRIMARY,1,3) ;-Creating Flag for Primary prompt
- ..S TYPE=$$OCCUP("","","",2,TYPEI) D
- ...N Y,DATE
- ...S Y=+$P($G(^AUPNVSIT(VISIT,0)),U) X ^DD("DD") S DATE=$P(Y,"@",1)
- ...I TYPEI="" S TYPE=$$GET^XUA4A72(PRVI,+$P($P($G(^AUPNVSIT(VISIT,0)),U),"."))
- ...I +TYPE=-2 S TYPE="*** CLASS not 'ACTIVE' on "_DATE_"***"
- ...I +TYPE=-1 S TYPE=""
- ...;I +TYPE>0 S TYPE="**** DELETE and RE-ENTER PROVIDER****"
- ...I +TYPE>0 S TYPE=""
- ..S GROUP=PRV_U_PRIMARY_U_TYPE_U_PRVI
- ..I PRIMARY["PRI" S PRVDR("PRIMARY")=PRV_U_IEN_U_PRVI
- ..S PRV(PRV,IEN)=GROUP
- K ^TMP("PXBU",$J,"PRV")
- ;
- B ;--Add line numbers
- ;create local arrays with data from existing providers
- I $D(PRV) D
- .S PXBC=0,PRV="" F S PRV=$O(PRV(PRV)) Q:PRV="" D
- ..S IEN=0 F S IEN=$O(PRV(PRV,IEN)) Q:IEN="" S PXBC=PXBC+1 D
- ...S PXBKY(PRV,PXBC)=$G(PRV(PRV,IEN)),PXBSAM(PXBC)=$G(PRV(PRV,IEN))
- ...S PXBSKY(PXBC,IEN)=$P(PRV(PRV,IEN),U,4)
- ...K PRV(PRV,IEN)
- FINISH ;--Finish up some variables
- S:FPRI'["PRI" FPRI=0 S:FPRI["PRI" FPRI=1
- ;FPRI=0 Then there is no Primary Selected yet
- EXIT ;--set a providers count
- S PXBCNT=+$G(PXBC)
- Q
- ;
- OCCUP(IEN,DATE,CODE,RETURN,CLASSIEN) ;--FORMAT PERSON CLASS TO DISPLAY
- ; IEN = Provider pointer to file# 200
- ; DATE = Date of occurrence of service
- ; CODE = Person class Code (if already known)
- ; **(Required step) If you use code leave IEN and DATE Blank
- ; RETURN = (Required) Flag to decide what format you want the
- ; return value.
- ; CLASSIEN = Ien of entry in the PERSON CLASS file#8932.1 If the Ien
- ; was saved this parameter could be sent in instead of CODE.
- ;
- ; 1 = IEN^OCCUPATION^SPECIALITY^SUBSPECIALITY^STATUS^DATE INACTIVATED^VA CODE
- ; 2 = Short Description
- ; 3 = Short Description^VA CODE
- ; *** If only CODE and RETURN = 1 There is no value or other
- ; value in the STATUS and DATE INACTIVATED fields.
- ;
- ; Output:
- ; -1 "no comment" function call to person class couldn't find
- ; a class for that person.
- ; -1^COMMENT This function is called incorrectly
- ; -2 "no comment" There is no ACTIVE person class for provider
- ; based on the date provided.
- ;
- ;N OCC,SPE,SUB,ENTRY,DIS,OCCL,TYPE,VACODE,ANS
- N OCC,SPEL,SUB,SUBL,ENTRY,DIS,OCCL,TYPE,VACODE,ANS
- ;--VALIDATE
- I (+$G(IEN)'>0)&($L(IEN)>0) Q -1_"^INVALID PERSON IEN"
- I '$G(IEN),'$G(DATE),$G(CODE)="",'$G(RETURN),'$G(CLASSIEN) Q -1_"^NO PARAMETERS"
- I '$G(IEN),'$G(DATE),$G(CODE)="",$G(RETURN),'$G(CLASSIEN) Q -1_"^NO PARAMETERS"
- I '$G(RETURN) Q -1_"^NO RETURN PARAMETER (Required)"
- I $G(RETURN)]"",(RETURN'<4!(RETURN'>0)) Q -1_"^RETURN MUST BE 1,2,or 3"
- I DATE]"",+DATE'>0 Q -1_"^INVALID FILEMAN DATE"
- I $G(IEN) Q:'$D(^VA(200,$G(IEN))) -1_"^NO SUCH IEN IN FILE# 200"
- I $G(IEN),$G(DATE) D I $G(RETURN)=1 Q TYPE
- .S TYPE=$$GET^XUA4A72(IEN,$P(DATE,".")),VACODE=$P(TYPE,U,7)
- I $G(IEN),$G(DATE),+TYPE<0 Q TYPE
- ;
- ;---CONVERT IEN TO CODE
- I $G(CLASSIEN) S CODE=$$IEN2CODE^XUA4A72(CLASSIEN)
- ;
- 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
- I '$G(TYPE) Q -1_"UNABLE TO IDENTIFY THE PERSON CLASS IEN" ;Often due to a missing VA CODE field
- S ENTRY=$G(^USC(8932.1,+TYPE,0))
- OCC ;---OCCUPATION
- S OCCL=$P(ENTRY,U)
- S OCC=$P($P(ENTRY,U)," ",1)
- I OCCL["Physicians (M.D" S OCC="Physician"
- I OCCL["Physician Assistant" S OCC=OCCL
- I OCCL["Speech, Language" S OCC="Language"
- I OCCL["Technologists" S OCC="Technical"
- I OCCL["Eye and Vision" S OCC="Ophthalmic"
- I OCCL["Respiratory, Rehab" S OCC="Therapist"
- I OCCL["Podiatric" S OCC="Podiatry"
- ;
- SPE ;--SPECIALITY
- S SPEL=$P(ENTRY,U,2)
- S SPE=$P(ENTRY,U,2)
- I SPEL["Registered Nurse" S SPE="R.N."
- I SPEL["Dentist" S SPE="Dentist"
- I SPEL["Clinical Services" S SPE="Clinical"
- I SPEL["Non-R.N.s" S SPE="Non R.N."
- I SPEL["Radiologic Sciences" S SPE="Radiology"
- I SPEL["Clinical Path" S SPE=""
- I SPEL["Physical Therap" S SPE="P.T."
- I SPEL["Obstetrics and Gynecology" S SPE="Ob. & Gyn."
- I SPEL["iatry and Neur" S SPE="Psyc & Neuro"
- I SPEL["Clinical Specialist" S SPE="Clinical"
- I SPEL["Registered Dietitian" S SPE="R. Dietitian"
- I SPEL["Rehabilitation Prac" S SPE="Rehabilitation"
- I OCC["Physician"&(SPE["Internal Medicine") S SPE="Internist"
- ;
- SUB ;--SUBSPECIALITY
- S SUBL=$P(ENTRY,U,3)
- S SUB=$P(ENTRY,U,3)
- I SUB["Counselor"&(SPE["Counselor") S SPE=""
- I SUB["Therapist"&(SPE["Therapist") S SPE=""
- I SUB["Nurse"&(SPE["Nurse") S SPE=""
- I SUB["Pediatric"&(SPE["Pediatric") S SPE=""
- I SUB["Psychiatry"&(SPE["Psychiatry") S SPE=""
- I SUB["Podiatri"&(SPE["Podiatri") S SPE=""
- I SUB["Clinical and Laboratory Immunology" S SUB="Clin & Lab Immunology"
- I SUB["Clinical & Laboratory Immunology" S SUB="Clin & Lab Immunology"
- I SUB["cine-Envir" S SUB="Occ & Environmental"
- I SUB["Child and Adolescent Psyc" S SUB="Pediatric Mental Health"
- I SUB["ist in Meta" S SUB="Metabolic"
- I SUB["ist in Pedia" S SUB="Pediatric"
- I SUB["ist in Renal" S SUB="Renal"
- I SUB["tion Intern" S SUB="Intern"
- I SUB["tion Coordin" S SUB="Coordinator"
- I SUB["tion Counselor" S SUB="Counselor"
- I SUB["for the Blind" S SUB="Orientation for Blind"
- I SUB["Dosimetrist" S SUB="Planning, Dosimetrist"
- I SPEL["Respiratory Care Pr"&(SUB'="") S SPE=""
- ;
- ;--CALCULATE THE BEST DISPLAY
- S DISL=OCCL_"-"_SPEL_"-"_SUBL
- S DIS=OCC_"/"_SPE_"/"_SUB
- I SUB[SPE S DIS=OCC_"/"_SUB
- I SPE="" S DIS=OCC_"/"_SUB
- I SUB="" S DIS=OCC_"/"_SPE
- AND I $L(DIS," and ")>1 D
- .N I F I=1:1:$L(DIS," ") I $P(DIS," ",I)="and" S $P(DIS," ",I)="&"
- I $L(DIS," and ")>1 G AND
- ;Q $E(DIS,1,40)_" "_$L(DIS)
- ;Q $E(DIS,1,40)_"***"_OCCL
- ;Q SPE_" *** "_SPEL
- ;Q SUB_" *** "_SUBL
- ;Q DISL_"~"_DIS
- ;Q ""_"~"_DIS
- I $G(RETURN)=2 Q DIS
- I $G(RETURN)=3 Q DIS_U_VACODE
- Q -1_"^SOMETHING BAD WRONG_SHOULDN'T BE HERE"
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBGPRV 7436 printed Jan 18, 2025@03:27:43 Page 2
- PXBGPRV ;ISL/JVS,ESW - GATHER PROVIDERS ;11/22/2019
- +1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,11,108,186,220,211**;Aug 12, 1996;Build 454
- +2 ;
- PRV(VISIT,PXBSKY,PXBKY,PXBSAM,PXBCNT,PRVDR,FPRI) ;--Gather the entries in the V PROVIDER file
- +1 ;
- +2 ;Output:
- +3 ; PXBSKY(PXBC,IEN)=PRVI
- +4 ; PXBKY(NAME,PXBC)=NAME^P^TYPE^PRVI
- +5 ; PXBSAM(PXBC)=NAME^P^TYPE^PRVI
- +6 ; PRVDR("PRIMARY")=NAME^IEN^PRVI
- +7 ; PXBCNT
- +8 ; FPRI
- +9 ;where:
- +10 ; PXBC - sequence in an order of providers name
- +11 ; IEN - of ^AUPNVPRV(
- +12 ; NAME - provider's name (LAST,FIRST...)
- +13 ; P - PRIMARY or SECONDARY
- +14 ; PRVI - IEN of ^VA(200,
- +15 ; PXBCNT - provider count
- +16 ; FPRI:
- +17 ; 0 - Primary not selected
- +18 ; 1 - Primary selected
- +19 ;
- +20 NEW IEN,QUANTITY,PROVIDER,PRIMARY,PRV,PRVN,GROUP,PXBC
- +21 NEW DIC,DR,DA,DIQ,PRVI,TYPE,TYPEI
- +22 ;
- +23 KILL ^TMP("PXBU",$JOB),PRV,PXBKY,VAUGHN,PXBSAM,PXBSKY,PXBCNT,PXBPRV,FPRI
- +24 KILL PRVDR
- +25 SET FPRI=""
- +26 ; create an array of current providers without duplicates, with their
- +27 ; ^(0) node as a value
- +28 IF $DATA(^AUPNVPRV("AD",VISIT))
- Begin DoDot:1
- +29 DO GETPRV^PXAPIOE(VISIT,"^TMP(""PXBU"",$J,""PRV"")")
- End DoDot:1
- +30 ;
- A ;--Set array with PROVIDERS
- +1 ;
- +2 IF $GET(^TMP("PXBU",$JOB,"PRV"))
- Begin DoDot:1
- +3 SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP("PXBU",$JOB,"PRV",IEN))
- if IEN'>0
- QUIT
- Begin DoDot:2
- +4 SET PRIMARY=$SELECT($PIECE(^(IEN),U,4)="P":"PRIMARY",1:"SECONDARY")
- +5 SET PRVI=+^(IEN)
- SET TYPEI=$PIECE(^(IEN),U,6)
- +6 SET DIC=200
- SET DIC1=DIC
- SET DR=.01
- SET DA=PRVI
- SET DIQ="PRVN"
- DO EN^DIQ1
- Begin DoDot:3
- +7 SET PRV=PRVN(DIC1,DA,DR)
- End DoDot:3
- +8 ;-Creating Flag for Primary prompt
- SET FPRI=FPRI_$EXTRACT(PRIMARY,1,3)
- +9 SET TYPE=$$OCCUP("","","",2,TYPEI)
- Begin DoDot:3
- +10 NEW Y,DATE
- +11 SET Y=+$PIECE($GET(^AUPNVSIT(VISIT,0)),U)
- XECUTE ^DD("DD")
- SET DATE=$PIECE(Y,"@",1)
- +12 IF TYPEI=""
- SET TYPE=$$GET^XUA4A72(PRVI,+$PIECE($PIECE($GET(^AUPNVSIT(VISIT,0)),U),"."))
- +13 IF +TYPE=-2
- SET TYPE="*** CLASS not 'ACTIVE' on "_DATE_"***"
- +14 IF +TYPE=-1
- SET TYPE=""
- +15 ;I +TYPE>0 S TYPE="**** DELETE and RE-ENTER PROVIDER****"
- +16 IF +TYPE>0
- SET TYPE=""
- End DoDot:3
- +17 SET GROUP=PRV_U_PRIMARY_U_TYPE_U_PRVI
- +18 IF PRIMARY["PRI"
- SET PRVDR("PRIMARY")=PRV_U_IEN_U_PRVI
- +19 SET PRV(PRV,IEN)=GROUP
- End DoDot:2
- End DoDot:1
- +20 KILL ^TMP("PXBU",$JOB,"PRV")
- +21 ;
- B ;--Add line numbers
- +1 ;create local arrays with data from existing providers
- +2 IF $DATA(PRV)
- Begin DoDot:1
- +3 SET PXBC=0
- SET PRV=""
- FOR
- SET PRV=$ORDER(PRV(PRV))
- if PRV=""
- QUIT
- Begin DoDot:2
- +4 SET IEN=0
- FOR
- SET IEN=$ORDER(PRV(PRV,IEN))
- if IEN=""
- QUIT
- SET PXBC=PXBC+1
- Begin DoDot:3
- +5 SET PXBKY(PRV,PXBC)=$GET(PRV(PRV,IEN))
- SET PXBSAM(PXBC)=$GET(PRV(PRV,IEN))
- +6 SET PXBSKY(PXBC,IEN)=$PIECE(PRV(PRV,IEN),U,4)
- +7 KILL PRV(PRV,IEN)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- FINISH ;--Finish up some variables
- +1 if FPRI'["PRI"
- SET FPRI=0
- if FPRI["PRI"
- SET FPRI=1
- +2 ;FPRI=0 Then there is no Primary Selected yet
- EXIT ;--set a providers count
- +1 SET PXBCNT=+$GET(PXBC)
- +2 QUIT
- +3 ;
- OCCUP(IEN,DATE,CODE,RETURN,CLASSIEN) ;--FORMAT PERSON CLASS TO DISPLAY
- +1 ; IEN = Provider pointer to file# 200
- +2 ; DATE = Date of occurrence of service
- +3 ; CODE = Person class Code (if already known)
- +4 ; **(Required step) If you use code leave IEN and DATE Blank
- +5 ; RETURN = (Required) Flag to decide what format you want the
- +6 ; return value.
- +7 ; CLASSIEN = Ien of entry in the PERSON CLASS file#8932.1 If the Ien
- +8 ; was saved this parameter could be sent in instead of CODE.
- +9 ;
- +10 ; 1 = IEN^OCCUPATION^SPECIALITY^SUBSPECIALITY^STATUS^DATE INACTIVATED^VA CODE
- +11 ; 2 = Short Description
- +12 ; 3 = Short Description^VA CODE
- +13 ; *** If only CODE and RETURN = 1 There is no value or other
- +14 ; value in the STATUS and DATE INACTIVATED fields.
- +15 ;
- +16 ; Output:
- +17 ; -1 "no comment" function call to person class couldn't find
- +18 ; a class for that person.
- +19 ; -1^COMMENT This function is called incorrectly
- +20 ; -2 "no comment" There is no ACTIVE person class for provider
- +21 ; based on the date provided.
- +22 ;
- +23 ;N OCC,SPE,SUB,ENTRY,DIS,OCCL,TYPE,VACODE,ANS
- +24 NEW OCC,SPEL,SUB,SUBL,ENTRY,DIS,OCCL,TYPE,VACODE,ANS
- +25 ;--VALIDATE
- +26 IF (+$GET(IEN)'>0)&($LENGTH(IEN)>0)
- QUIT -1_"^INVALID PERSON IEN"
- +27 IF '$GET(IEN)
- IF '$GET(DATE)
- IF $GET(CODE)=""
- IF '$GET(RETURN)
- IF '$GET(CLASSIEN)
- QUIT -1_"^NO PARAMETERS"
- +28 IF '$GET(IEN)
- IF '$GET(DATE)
- IF $GET(CODE)=""
- IF $GET(RETURN)
- IF '$GET(CLASSIEN)
- QUIT -1_"^NO PARAMETERS"
- +29 IF '$GET(RETURN)
- QUIT -1_"^NO RETURN PARAMETER (Required)"
- +30 IF $GET(RETURN)]""
- IF (RETURN'<4!(RETURN'>0))
- QUIT -1_"^RETURN MUST BE 1,2,or 3"
- +31 IF DATE]""
- IF +DATE'>0
- QUIT -1_"^INVALID FILEMAN DATE"
- +32 IF $GET(IEN)
- if '$DATA(^VA(200,$GET(IEN)))
- QUIT -1_"^NO SUCH IEN IN FILE# 200"
- +33 IF $GET(IEN)
- IF $GET(DATE)
- Begin DoDot:1
- +34 SET TYPE=$$GET^XUA4A72(IEN,$PIECE(DATE,"."))
- SET VACODE=$PIECE(TYPE,U,7)
- End DoDot:1
- IF $GET(RETURN)=1
- QUIT TYPE
- +35 IF $GET(IEN)
- IF $GET(DATE)
- IF +TYPE<0
- QUIT TYPE
- +36 ;
- +37 ;---CONVERT IEN TO CODE
- +38 IF $GET(CLASSIEN)
- SET CODE=$$IEN2CODE^XUA4A72(CLASSIEN)
- +39 ;
- +40 IF $GET(CODE)]""
- IF '$GET(IEN)
- IF '$GET(DATE)
- SET TYPE=$ORDER(^USC(8932.1,"F",$GET(CODE),0))
- SET VACODE=CODE
- IF $GET(RETURN)=1
- SET ANS=TYPE_U_$GET(^USC(8932.1,TYPE,0))
- QUIT ANS
- +41 ;Often due to a missing VA CODE field
- IF '$GET(TYPE)
- QUIT -1_"UNABLE TO IDENTIFY THE PERSON CLASS IEN"
- +42 SET ENTRY=$GET(^USC(8932.1,+TYPE,0))
- OCC ;---OCCUPATION
- +1 SET OCCL=$PIECE(ENTRY,U)
- +2 SET OCC=$PIECE($PIECE(ENTRY,U)," ",1)
- +3 IF OCCL["Physicians (M.D"
- SET OCC="Physician"
- +4 IF OCCL["Physician Assistant"
- SET OCC=OCCL
- +5 IF OCCL["Speech, Language"
- SET OCC="Language"
- +6 IF OCCL["Technologists"
- SET OCC="Technical"
- +7 IF OCCL["Eye and Vision"
- SET OCC="Ophthalmic"
- +8 IF OCCL["Respiratory, Rehab"
- SET OCC="Therapist"
- +9 IF OCCL["Podiatric"
- SET OCC="Podiatry"
- +10 ;
- SPE ;--SPECIALITY
- +1 SET SPEL=$PIECE(ENTRY,U,2)
- +2 SET SPE=$PIECE(ENTRY,U,2)
- +3 IF SPEL["Registered Nurse"
- SET SPE="R.N."
- +4 IF SPEL["Dentist"
- SET SPE="Dentist"
- +5 IF SPEL["Clinical Services"
- SET SPE="Clinical"
- +6 IF SPEL["Non-R.N.s"
- SET SPE="Non R.N."
- +7 IF SPEL["Radiologic Sciences"
- SET SPE="Radiology"
- +8 IF SPEL["Clinical Path"
- SET SPE=""
- +9 IF SPEL["Physical Therap"
- SET SPE="P.T."
- +10 IF SPEL["Obstetrics and Gynecology"
- SET SPE="Ob. & Gyn."
- +11 IF SPEL["iatry and Neur"
- SET SPE="Psyc & Neuro"
- +12 IF SPEL["Clinical Specialist"
- SET SPE="Clinical"
- +13 IF SPEL["Registered Dietitian"
- SET SPE="R. Dietitian"
- +14 IF SPEL["Rehabilitation Prac"
- SET SPE="Rehabilitation"
- +15 IF OCC["Physician"&(SPE["Internal Medicine")
- SET SPE="Internist"
- +16 ;
- SUB ;--SUBSPECIALITY
- +1 SET SUBL=$PIECE(ENTRY,U,3)
- +2 SET SUB=$PIECE(ENTRY,U,3)
- +3 IF SUB["Counselor"&(SPE["Counselor")
- SET SPE=""
- +4 IF SUB["Therapist"&(SPE["Therapist")
- SET SPE=""
- +5 IF SUB["Nurse"&(SPE["Nurse")
- SET SPE=""
- +6 IF SUB["Pediatric"&(SPE["Pediatric")
- SET SPE=""
- +7 IF SUB["Psychiatry"&(SPE["Psychiatry")
- SET SPE=""
- +8 IF SUB["Podiatri"&(SPE["Podiatri")
- SET SPE=""
- +9 IF SUB["Clinical and Laboratory Immunology"
- SET SUB="Clin & Lab Immunology"
- +10 IF SUB["Clinical & Laboratory Immunology"
- SET SUB="Clin & Lab Immunology"
- +11 IF SUB["cine-Envir"
- SET SUB="Occ & Environmental"
- +12 IF SUB["Child and Adolescent Psyc"
- SET SUB="Pediatric Mental Health"
- +13 IF SUB["ist in Meta"
- SET SUB="Metabolic"
- +14 IF SUB["ist in Pedia"
- SET SUB="Pediatric"
- +15 IF SUB["ist in Renal"
- SET SUB="Renal"
- +16 IF SUB["tion Intern"
- SET SUB="Intern"
- +17 IF SUB["tion Coordin"
- SET SUB="Coordinator"
- +18 IF SUB["tion Counselor"
- SET SUB="Counselor"
- +19 IF SUB["for the Blind"
- SET SUB="Orientation for Blind"
- +20 IF SUB["Dosimetrist"
- SET SUB="Planning, Dosimetrist"
- +21 IF SPEL["Respiratory Care Pr"&(SUB'="")
- SET SPE=""
- +22 ;
- +23 ;--CALCULATE THE BEST DISPLAY
- +24 SET DISL=OCCL_"-"_SPEL_"-"_SUBL
- +25 SET DIS=OCC_"/"_SPE_"/"_SUB
- +26 IF SUB[SPE
- SET DIS=OCC_"/"_SUB
- +27 IF SPE=""
- SET DIS=OCC_"/"_SUB
- +28 IF SUB=""
- SET DIS=OCC_"/"_SPE
- AND IF $LENGTH(DIS," and ")>1
- Begin DoDot:1
- +1 NEW I
- FOR I=1:1:$LENGTH(DIS," ")
- IF $PIECE(DIS," ",I)="and"
- SET $PIECE(DIS," ",I)="&"
- End DoDot:1
- +2 IF $LENGTH(DIS," and ")>1
- GOTO AND
- +3 ;Q $E(DIS,1,40)_" "_$L(DIS)
- +4 ;Q $E(DIS,1,40)_"***"_OCCL
- +5 ;Q SPE_" *** "_SPEL
- +6 ;Q SUB_" *** "_SUBL
- +7 ;Q DISL_"~"_DIS
- +8 ;Q ""_"~"_DIS
- +9 IF $GET(RETURN)=2
- QUIT DIS
- +10 IF $GET(RETURN)=3
- QUIT DIS_U_VACODE
- +11 QUIT -1_"^SOMETHING BAD WRONG_SHOULDN'T BE HERE"