PXRRPECS.m

PXRRPECS ;ISL/PKR - Build a list of Person Class entries. ;12/11/96

 ;;1.0;PCE PATIENT CARE ENCOUNTER;**12**;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,30)

 . 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

 ;

PXRRPECS  ;ISL/PKR - Build a list of Person Class entries. ;12/11/96

 +1       ;;1.0;PCE PATIENT CARE ENCOUNTER;**12**;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,30)

 +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       ;