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 Dec 13, 2024@02:26: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"
