PXRRPECS ;ISL/PKR - Build a list of Person Class entries. ;12/11/96
;;1.0;PCE PATIENT CARE ENCOUNTER;**12,147**;Aug 12, 1996
;
;=======================================================================
PCLASS ;Build a list of person classes.
N BELL,IC,INDENT,JC,NOCC,NS,NSPEC,NSUB,OCC,OCCIEN,PCLASS
N SELECT,SOCC,SOCCW,SPEC,SPECIEN,SSPEC,SSPECW,SUB,SSUB,TEMP,WC,X,Y
;We will need a DBIA for reading the Person Class file.
;Build a list of the OCCUPATION entries in the Person Class file.
S IC=0
F S IC=$O(^USC(8932.1,IC)) Q:+IC=0 D
. S TEMP=$P(^USC(8932.1,IC,0),U,1)
. I $L(TEMP)>0 S OCC($$UPPRCASE^PXRRPECU(TEMP))=TEMP
;
;Count the number of Occupation entries.
S NOCC=0
S IC=""
F S IC=$O(OCC(IC)) Q:IC="" D
. S NOCC=NOCC+1
;
S BELL=$C(7)
;Set the wildcard to be *.
S WC="*"
;NS is NOT SPECIFIED.
S NS="NOT SPECIFIED"
S INDENT=3
S NCL=0
K PXRRPECL
MPROMPT W !,"Select PERSON CLASS (OCCUPATION, SPECIALTY, SUBSPECIALTY)"
K DTOUT,DUOUT
W !
NPCLASS ;
I NCL'<1 W !!,"Select another PERSON CLASS OCCUPATION"
;Select an occupation.
NOCC S DIR(0)="FAOU^1:60"
S DIR("?")="^D OCCHLP^PXRRPECS"
S DIR("??")="^D LISTA^PXRRPECU(.OCC)"
S DIR("A")=" Select OCCUPATION (enter "_WC_" for all, return to end selection): "
W !
D ^DIR
K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!$D(DUOUT) Q
S SOCC=$$FDME^PXRRPECU(Y,.OCC)
I SOCC=-1 W " ??",BELL G NOCC
I ($P(SOCC,U,1)="")&(NCL=0) D G MPROMPT
. W !,"You must select a person class!"
I $P(SOCC,U,1)="" Q
I $P(SOCC,U,1)=WC S SOCCW=1
E S SOCCW=0
;
;Build a list of iens for SOCC (Selected OCCupation).
K OCCIEN
K SPEC
I ('SOCCW) D
. S TEMP=$E($P(SOCC,U,2),1,62)
. S IC=0
. F S IC=$O(^USC(8932.1,"B",TEMP,IC)) Q:+IC=0 D
.. S OCCIEN(IC)=""
;
;Build a list of specialties valid for SOCC.
S IC=0
F S IC=$O(OCCIEN(IC)) Q:+IC=0 D
. S TEMP=$P(^USC(8932.1,IC,0),U,2)
. I TEMP="" S TEMP=NS
. S SPEC($$UPPRCASE^PXRRPECU(TEMP))=TEMP
;
;Special case for Occupation selected as wildcard.
I SOCCW D
. S IC=0
. F S IC=$O(^USC(8932.1,IC)) Q:+IC=0 D
.. S TEMP=$P(^USC(8932.1,IC,0),U,2)
.. I TEMP="" S TEMP=NS
.. S SPEC($$UPPRCASE^PXRRPECU(TEMP))=TEMP
;
;Count the number of Specialty entries compatible with the selected
;Occupation.
S NSPEC=0
S IC=0
F S IC=$O(SPEC(IC)) Q:IC="" D
. S NSPEC=NSPEC+1
;
I NSPEC=0 D G NPCLASS
. W !,"There are no specialties for:"
. W !,?INDENT,"OCCUPATION: ",$P(SOCC,U,1)
. S NCL=NCL+1
. S PXRRPECL(NCL)=$P(SOCC,U,2)_U_NS_U_NS
;
;Select a specialty.
S SSPEC=""
NSPEC I (NCL>0)&($L(SSPEC)>0) D VERIFY^PXRRPECU
S DIR(0)="FAOU^1:50"
S DIR("?")="^D SPECHLP^PXRRPECS"
S DIR("??")="^D LISTA^PXRRPECU(.SPEC)"
S DIR("A")=" Select SPECIALTY (enter "_WC_" for all, return to change OCCUPATION): "
W !!,"The currently selected OCCUPATION is:"
W !," ",$P(SOCC,U,2)
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT) Q
I $D(DUOUT) G NOCC
I $L(Y)=0 G NPCLASS
S SSPEC=$$FDME^PXRRPECU(Y,.SPEC)
I $P(SSPEC,U,1)="" G NPCLASS
I SSPEC=-1 W " ??",BELL G NSPEC
I $P(SSPEC,U,1)=WC S SSPECW=1
E S SSPECW=0
;
;Build a list of iens for SSPEC (Selected SPECialty). Trim the OCCIEN
;list so it only contains entries valid for SOCC and SSPEC.
K SPECIEN
K SUB
S IC=0
F S IC=$O(OCCIEN(IC)) Q:+IC=0 D
. S SPECIEN(IC)=OCCIEN(IC)
;
;If SSPEC was selected as the wildcard then we don't need to do
;anything.
I ('SSPECW)&('SOCCW) D
. S TEMP=$P(SSPEC,U,2)
. S IC=0
. F S IC=$O(SPECIEN(IC)) Q:+IC=0 D
.. I $P(^USC(8932.1,IC,0),U,2)'=TEMP K SPECIEN(IC)
;
;Special case with SOCC=WC and SSPEC'=WC
I ('SSPECW)&(SOCCW) D
. S TEMP=$P(SSPEC,U,2)
. S IC=0
. F S IC=$O(^USC(8932.1,IC)) Q:+IC=0 D
.. I $P(^USC(8932.1,IC,0),U,2)=TEMP S SPECIEN(IC)=""
;
;Build a list of subspecialties valid for SOCC and SSPEC.
S IC=0
F S IC=$O(SPECIEN(IC)) Q:+IC=0 D
. S TEMP=$P(^USC(8932.1,IC,0),U,3)
. I TEMP="" S TEMP=NS
. S SUB($$UPPRCASE^PXRRPECU(TEMP))=TEMP
;
;Special case SOCC and SSPEC are wild.
I (SSPECW)&(SOCCW) D
. S IC=0
. F S IC=$O(^USC(8932.1,IC)) Q:+IC=0 D
.. S TEMP=$P(^USC(8932.1,IC,0),U,3)
.. I TEMP="" S TEMP=NS
.. S SUB($$UPPRCASE^PXRRPECU(TEMP))=TEMP
;
;Count the number of entries.
S NSUB=0
S IC=""
F S IC=$O(SUB(IC)) Q:IC="" D
. S NSUB=NSUB+1
;
I (NSUB=0)!((NSUB=1)&($D(SUB(NS)))) D G NSPEC
. W !,"There are no subspecialties for:"
. W !,?INDENT,"OCCUPATION: ",$P(SOCC,U,1)
. W !,?INDENT,"SPECIALTY: ",$P(SSPEC,U,1)
. S NCL=NCL+1
. S PXRRPECL(NCL)=$P(SOCC,U,2)_U_$P(SSPEC,U,2)_U_NS
;
;Select a subspecialty.
NSUB S DIR(0)="FAOU^1:50"
S DIR("?")="^D SUBHLP^PXRRPECS"
S DIR("??")="^D LISTA^PXRRPECU(.SUB)"
S DIR("A")=" Select SUBSPECIALTY (enter "_WC_" for all): "
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT) Q
I $D(DUOUT) G NSPEC
I $L(Y)=0 S SSUB=NS_U_NS
E S SSUB=$$FDME^PXRRPECU(Y,.SUB)
I SSUB=-1 W " ??",BELL G NSUB
;
;Save the selections.
S TEMP=$L($P(SOCC,U,1))+$L($P(SSPEC,U,1))+$L($P(SSUB,U,1))
I TEMP=0 Q
I TEMP>0 D
. S NCL=NCL+1
. S PXRRPECL(NCL)=$P(SOCC,U,2)_U_$P(SSPEC,U,2)_U_$P(SSUB,U,2)
I $D(DUOUT) G PCLASS
I (NCL=0)&($D(DIRUT)!$D(DUOUT)) Q
I (NCL=0) W !,"You must select a PERSON CLASS!" G PCLASS
G NSPEC
;
;=======================================================================
OCCHLP ;Help for occupation input.
N PROMPT
W !!,"Answer with an OCCUPATION, note ",WC," matches all OCCUPATIONS"
S PROMPT="Do you want the entire "_NOCC_"-entry occupation list? "
I $$GETYORN^PXRRPECU(PROMPT) D LISTA^PXRRPECU(.OCC)
Q
;
;=======================================================================
SPECHLP ;Help for specialty input.
N PROMPT
W !!,"Answer with a SPECIALTY, note ",WC," matches all SPECIALTIES"
S PROMPT="Do you want the entire "_NSPEC_"-entry specialty list? "
I $$GETYORN^PXRRPECU(PROMPT) D LISTA^PXRRPECU(.SPEC)
Q
;
;=======================================================================
SUBHLP ;Help for subspecialty input.
N PROMPT
W !!,"Answer with a SUBSPECIALTY, note ",WC," matches all SUBSPECIALTIES"
S PROMPT="Do you want the entire "_NSUB_"-entry subspecialty list? "
I $$GETYORN^PXRRPECU(PROMPT) D LISTA^PXRRPECU(.SUB)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRRPECS 6293 printed Dec 13, 2024@02:31:07 Page 2
PXRRPECS ;ISL/PKR - Build a list of Person Class entries. ;12/11/96
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**12,147**;Aug 12, 1996
+2 ;
+3 ;=======================================================================
PCLASS ;Build a list of person classes.
+1 NEW BELL,IC,INDENT,JC,NOCC,NS,NSPEC,NSUB,OCC,OCCIEN,PCLASS
+2 NEW SELECT,SOCC,SOCCW,SPEC,SPECIEN,SSPEC,SSPECW,SUB,SSUB,TEMP,WC,X,Y
+3 ;We will need a DBIA for reading the Person Class file.
+4 ;Build a list of the OCCUPATION entries in the Person Class file.
+5 SET IC=0
+6 FOR
SET IC=$ORDER(^USC(8932.1,IC))
if +IC=0
QUIT
Begin DoDot:1
+7 SET TEMP=$PIECE(^USC(8932.1,IC,0),U,1)
+8 IF $LENGTH(TEMP)>0
SET OCC($$UPPRCASE^PXRRPECU(TEMP))=TEMP
End DoDot:1
+9 ;
+10 ;Count the number of Occupation entries.
+11 SET NOCC=0
+12 SET IC=""
+13 FOR
SET IC=$ORDER(OCC(IC))
if IC=""
QUIT
Begin DoDot:1
+14 SET NOCC=NOCC+1
End DoDot:1
+15 ;
+16 SET BELL=$CHAR(7)
+17 ;Set the wildcard to be *.
+18 SET WC="*"
+19 ;NS is NOT SPECIFIED.
+20 SET NS="NOT SPECIFIED"
+21 SET INDENT=3
+22 SET NCL=0
+23 KILL PXRRPECL
MPROMPT WRITE !,"Select PERSON CLASS (OCCUPATION, SPECIALTY, SUBSPECIALTY)"
+1 KILL DTOUT,DUOUT
+2 WRITE !
NPCLASS ;
+1 IF NCL'<1
WRITE !!,"Select another PERSON CLASS OCCUPATION"
+2 ;Select an occupation.
NOCC SET DIR(0)="FAOU^1:60"
+1 SET DIR("?")="^D OCCHLP^PXRRPECS"
+2 SET DIR("??")="^D LISTA^PXRRPECU(.OCC)"
+3 SET DIR("A")=" Select OCCUPATION (enter "_WC_" for all, return to end selection): "
+4 WRITE !
+5 DO ^DIR
+6 KILL DIR
+7 IF $DATA(DIROUT)
SET DTOUT=1
+8 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+9 SET SOCC=$$FDME^PXRRPECU(Y,.OCC)
+10 IF SOCC=-1
WRITE " ??",BELL
GOTO NOCC
+11 IF ($PIECE(SOCC,U,1)="")&(NCL=0)
Begin DoDot:1
+12 WRITE !,"You must select a person class!"
End DoDot:1
GOTO MPROMPT
+13 IF $PIECE(SOCC,U,1)=""
QUIT
+14 IF $PIECE(SOCC,U,1)=WC
SET SOCCW=1
+15 IF '$TEST
SET SOCCW=0
+16 ;
+17 ;Build a list of iens for SOCC (Selected OCCupation).
+18 KILL OCCIEN
+19 KILL SPEC
+20 IF ('SOCCW)
Begin DoDot:1
+21 SET TEMP=$EXTRACT($PIECE(SOCC,U,2),1,62)
+22 SET IC=0
+23 FOR
SET IC=$ORDER(^USC(8932.1,"B",TEMP,IC))
if +IC=0
QUIT
Begin DoDot:2
+24 SET OCCIEN(IC)=""
End DoDot:2
End DoDot:1
+25 ;
+26 ;Build a list of specialties valid for SOCC.
+27 SET IC=0
+28 FOR
SET IC=$ORDER(OCCIEN(IC))
if +IC=0
QUIT
Begin DoDot:1
+29 SET TEMP=$PIECE(^USC(8932.1,IC,0),U,2)
+30 IF TEMP=""
SET TEMP=NS
+31 SET SPEC($$UPPRCASE^PXRRPECU(TEMP))=TEMP
End DoDot:1
+32 ;
+33 ;Special case for Occupation selected as wildcard.
+34 IF SOCCW
Begin DoDot:1
+35 SET IC=0
+36 FOR
SET IC=$ORDER(^USC(8932.1,IC))
if +IC=0
QUIT
Begin DoDot:2
+37 SET TEMP=$PIECE(^USC(8932.1,IC,0),U,2)
+38 IF TEMP=""
SET TEMP=NS
+39 SET SPEC($$UPPRCASE^PXRRPECU(TEMP))=TEMP
End DoDot:2
End DoDot:1
+40 ;
+41 ;Count the number of Specialty entries compatible with the selected
+42 ;Occupation.
+43 SET NSPEC=0
+44 SET IC=0
+45 FOR
SET IC=$ORDER(SPEC(IC))
if IC=""
QUIT
Begin DoDot:1
+46 SET NSPEC=NSPEC+1
End DoDot:1
+47 ;
+48 IF NSPEC=0
Begin DoDot:1
+49 WRITE !,"There are no specialties for:"
+50 WRITE !,?INDENT,"OCCUPATION: ",$PIECE(SOCC,U,1)
+51 SET NCL=NCL+1
+52 SET PXRRPECL(NCL)=$PIECE(SOCC,U,2)_U_NS_U_NS
End DoDot:1
GOTO NPCLASS
+53 ;
+54 ;Select a specialty.
+55 SET SSPEC=""
NSPEC IF (NCL>0)&($LENGTH(SSPEC)>0)
DO VERIFY^PXRRPECU
+1 SET DIR(0)="FAOU^1:50"
+2 SET DIR("?")="^D SPECHLP^PXRRPECS"
+3 SET DIR("??")="^D LISTA^PXRRPECU(.SPEC)"
+4 SET DIR("A")=" Select SPECIALTY (enter "_WC_" for all, return to change OCCUPATION): "
+5 WRITE !!,"The currently selected OCCUPATION is:"
+6 WRITE !," ",$PIECE(SOCC,U,2)
+7 DO ^DIR
KILL DIR
+8 IF $DATA(DIROUT)
SET DTOUT=1
+9 IF $DATA(DTOUT)
QUIT
+10 IF $DATA(DUOUT)
GOTO NOCC
+11 IF $LENGTH(Y)=0
GOTO NPCLASS
+12 SET SSPEC=$$FDME^PXRRPECU(Y,.SPEC)
+13 IF $PIECE(SSPEC,U,1)=""
GOTO NPCLASS
+14 IF SSPEC=-1
WRITE " ??",BELL
GOTO NSPEC
+15 IF $PIECE(SSPEC,U,1)=WC
SET SSPECW=1
+16 IF '$TEST
SET SSPECW=0
+17 ;
+18 ;Build a list of iens for SSPEC (Selected SPECialty). Trim the OCCIEN
+19 ;list so it only contains entries valid for SOCC and SSPEC.
+20 KILL SPECIEN
+21 KILL SUB
+22 SET IC=0
+23 FOR
SET IC=$ORDER(OCCIEN(IC))
if +IC=0
QUIT
Begin DoDot:1
+24 SET SPECIEN(IC)=OCCIEN(IC)
End DoDot:1
+25 ;
+26 ;If SSPEC was selected as the wildcard then we don't need to do
+27 ;anything.
+28 IF ('SSPECW)&('SOCCW)
Begin DoDot:1
+29 SET TEMP=$PIECE(SSPEC,U,2)
+30 SET IC=0
+31 FOR
SET IC=$ORDER(SPECIEN(IC))
if +IC=0
QUIT
Begin DoDot:2
+32 IF $PIECE(^USC(8932.1,IC,0),U,2)'=TEMP
KILL SPECIEN(IC)
End DoDot:2
End DoDot:1
+33 ;
+34 ;Special case with SOCC=WC and SSPEC'=WC
+35 IF ('SSPECW)&(SOCCW)
Begin DoDot:1
+36 SET TEMP=$PIECE(SSPEC,U,2)
+37 SET IC=0
+38 FOR
SET IC=$ORDER(^USC(8932.1,IC))
if +IC=0
QUIT
Begin DoDot:2
+39 IF $PIECE(^USC(8932.1,IC,0),U,2)=TEMP
SET SPECIEN(IC)=""
End DoDot:2
End DoDot:1
+40 ;
+41 ;Build a list of subspecialties valid for SOCC and SSPEC.
+42 SET IC=0
+43 FOR
SET IC=$ORDER(SPECIEN(IC))
if +IC=0
QUIT
Begin DoDot:1
+44 SET TEMP=$PIECE(^USC(8932.1,IC,0),U,3)
+45 IF TEMP=""
SET TEMP=NS
+46 SET SUB($$UPPRCASE^PXRRPECU(TEMP))=TEMP
End DoDot:1
+47 ;
+48 ;Special case SOCC and SSPEC are wild.
+49 IF (SSPECW)&(SOCCW)
Begin DoDot:1
+50 SET IC=0
+51 FOR
SET IC=$ORDER(^USC(8932.1,IC))
if +IC=0
QUIT
Begin DoDot:2
+52 SET TEMP=$PIECE(^USC(8932.1,IC,0),U,3)
+53 IF TEMP=""
SET TEMP=NS
+54 SET SUB($$UPPRCASE^PXRRPECU(TEMP))=TEMP
End DoDot:2
End DoDot:1
+55 ;
+56 ;Count the number of entries.
+57 SET NSUB=0
+58 SET IC=""
+59 FOR
SET IC=$ORDER(SUB(IC))
if IC=""
QUIT
Begin DoDot:1
+60 SET NSUB=NSUB+1
End DoDot:1
+61 ;
+62 IF (NSUB=0)!((NSUB=1)&($DATA(SUB(NS))))
Begin DoDot:1
+63 WRITE !,"There are no subspecialties for:"
+64 WRITE !,?INDENT,"OCCUPATION: ",$PIECE(SOCC,U,1)
+65 WRITE !,?INDENT,"SPECIALTY: ",$PIECE(SSPEC,U,1)
+66 SET NCL=NCL+1
+67 SET PXRRPECL(NCL)=$PIECE(SOCC,U,2)_U_$PIECE(SSPEC,U,2)_U_NS
End DoDot:1
GOTO NSPEC
+68 ;
+69 ;Select a subspecialty.
NSUB SET DIR(0)="FAOU^1:50"
+1 SET DIR("?")="^D SUBHLP^PXRRPECS"
+2 SET DIR("??")="^D LISTA^PXRRPECU(.SUB)"
+3 SET DIR("A")=" Select SUBSPECIALTY (enter "_WC_" for all): "
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DIROUT)
SET DTOUT=1
+6 IF $DATA(DTOUT)
QUIT
+7 IF $DATA(DUOUT)
GOTO NSPEC
+8 IF $LENGTH(Y)=0
SET SSUB=NS_U_NS
+9 IF '$TEST
SET SSUB=$$FDME^PXRRPECU(Y,.SUB)
+10 IF SSUB=-1
WRITE " ??",BELL
GOTO NSUB
+11 ;
+12 ;Save the selections.
+13 SET TEMP=$LENGTH($PIECE(SOCC,U,1))+$LENGTH($PIECE(SSPEC,U,1))+$LENGTH($PIECE(SSUB,U,1))
+14 IF TEMP=0
QUIT
+15 IF TEMP>0
Begin DoDot:1
+16 SET NCL=NCL+1
+17 SET PXRRPECL(NCL)=$PIECE(SOCC,U,2)_U_$PIECE(SSPEC,U,2)_U_$PIECE(SSUB,U,2)
End DoDot:1
+18 IF $DATA(DUOUT)
GOTO PCLASS
+19 IF (NCL=0)&($DATA(DIRUT)!$DATA(DUOUT))
QUIT
+20 IF (NCL=0)
WRITE !,"You must select a PERSON CLASS!"
GOTO PCLASS
+21 GOTO NSPEC
+22 ;
+23 ;=======================================================================
OCCHLP ;Help for occupation input.
+1 NEW PROMPT
+2 WRITE !!,"Answer with an OCCUPATION, note ",WC," matches all OCCUPATIONS"
+3 SET PROMPT="Do you want the entire "_NOCC_"-entry occupation list? "
+4 IF $$GETYORN^PXRRPECU(PROMPT)
DO LISTA^PXRRPECU(.OCC)
+5 QUIT
+6 ;
+7 ;=======================================================================
SPECHLP ;Help for specialty input.
+1 NEW PROMPT
+2 WRITE !!,"Answer with a SPECIALTY, note ",WC," matches all SPECIALTIES"
+3 SET PROMPT="Do you want the entire "_NSPEC_"-entry specialty list? "
+4 IF $$GETYORN^PXRRPECU(PROMPT)
DO LISTA^PXRRPECU(.SPEC)
+5 QUIT
+6 ;
+7 ;=======================================================================
SUBHLP ;Help for subspecialty input.
+1 NEW PROMPT
+2 WRITE !!,"Answer with a SUBSPECIALTY, note ",WC," matches all SUBSPECIALTIES"
+3 SET PROMPT="Do you want the entire "_NSUB_"-entry subspecialty list? "
+4 IF $$GETYORN^PXRRPECU(PROMPT)
DO LISTA^PXRRPECU(.SUB)
+5 QUIT
+6 ;
