APCLVL03.m

APCLVL03 ; IHS/CMI/LAB - SCREEN LOGIC ; 

 ;;2.0;IHS PCC SUITE;**2,4,7**;MAY 14, 2009

 ;

MEAS ;EP - measurements and values

 ;get measurement type and value range and store as T_U_RANGE

 W !,"With this selection item you will be prompted to enter which measurement types"

 W !,"you want included in the VGEN search.  When you select a measurement type you"

 W !,"will be asked to include all values of the measurement or to just include"

 W !,"a user specified range of values.",!

GETMEAS ;

 K APCLMSR

GETMEAS1 ;

 W !

 K DIC S DIC="^AUTTMSR(",DIC(0)="AEMQ" D ^DIC K DIC,DA

 I Y=-1,'$D(APCLMSR) W !,"no measurements selected." D PAUSE^APCLVL01 Q

 I Y=-1 D SETRPT Q

 S APCLMT=+Y,APCLMSR(APCLMT)="",APCLMTT=$P(^AUTTMSR(APCLMT,0),U)

 ;now get value

 S DIR(0)="S^A:ANY/ALL "_APCLMTT_" Values;S:Selected Range of "_APCLMTT_" Values",DIR("A")="Include which "_APCLMTT_" Values" KILL DA

 S DIR("B")="A" D ^DIR KILL DIR

 I $D(DIRUT) S APCLMSR(APCLMT)="" W !,"skipping measurement ",APCLMTT K APCLMSR(APCLMT) G GETMEAS1

 I Y="A" G GETMEAS1

MVAL ;GET VALUE RANGE

 S DIR(0)="F^1:999",DIR("A")="Enter the value range for "_APCLMTT

 S APCLMTVG=$O(^APCLVGMS("B",APCLMT,0))

 I 'APCLMTVG W !,"value range search not available for that measurement, all values will be included." G GETMEAS1

 S DIR("?")="Enter the value range for "_APCLMTT

 S X=0,C=0 F  S X=$O(^APCLVGMS(APCLMTVG,1,X)) Q:X'=+X  S C=C+1,DIR("?",C)=^APCLVGMS(APCLMTVG,1,X,0)

 KILL DA D ^DIR KILL DIR

 I $D(DIRUT) K APCLMSR(APCLMT) G GETMEAS1

 S (X,APCLVR)=Y X ^APCLVGMS(APCLMTVG,2)

 I '$D(X) W !,"Invalid range for ",APCLMTT D  G MVAL

 .S X=0,C=0 F  S X=$O(^APCLVGMS(APCLMTVG,1,X)) Q:X'=+X  W !,^APCLVGMS(APCLMTVG,1,X,0)

 S APCLMSR(APCLMT)=APCLVR

 G GETMEAS1

 ;

SETRPT ;

 S (X,Y)=0 F  S X=$O(APCLMSR(X)) Q:X'=+X  D

 .S Y=Y+1

 .S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""

 .S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,Y,0)=X_"^"_APCLMSR(X)

 .S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X,Y)=""

 .S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_Y_"^"_Y

 Q

HESCR ;

 I V=R S D=1 Q

 Q

EDIP ;

 NEW A,M,B,H,S

 S H=X,S=""

 S A=$$STRIP^XLFSTR(X," ")

 F B=1:1 S C=$P(A,",",B) Q:C=""  D

 .S X=C X ^AUTTMSR($P(^APCLVGMS(APCLMTVG,0),U),12) I '$D(X) S S=1

 I S K X Q

 S APCLVR=A

 Q

NUMIP ;

 NEW A,M

 S M=$P(^APCLVGMS(APCLMTVG,0),U)

 S A=X

 S X=$P(A,"-",1) X ^AUTTMSR(M,12) I '$D(X) Q

 S X=$P(A,"-",2) X ^AUTTMSR(M,12) I '$D(X) Q

 S X=A

 Q

MSRSCR ;

 NEW A,B,C,D,R,F,S,E,G

 S Y=0 F  S Y=$O(^AUPNVMSR("AD",APCLVIEN,Y)) Q:Y'=+Y!(X=1)  I '$P($G(^AUPNVMSR(Y,2)),U,1) S A=$P(^AUPNVMSR(Y,0),U,1) I $D(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A)) D

 .;check value if need be

 .S B=$O(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A,0))

 .S R=$P(^APCLVRPT(APCLRPT,11,APCLI,11,B,0),U,2)

 .I R="" S X=1,X(1)="" Q

 .S V=$P(^AUPNVMSR(Y,0),U,4)

 .S C=$P(^AUTTMSR(A,0),U)

 .S E=$O(^APCLVGMS("B",A,0))

 .S G=$P(^APCLVGMS(E,0),U,2)

 .K D

 .I G D NUMSCR I 1

 .E  D @(C_"SCR")

 .Q:'$D(D)

 .S X=1,X(1)=""

 .Q

 Q

NUMSCR ;

 S F=$P(R,"-"),S=$P(R,"-",2)

 I +V<F Q

 I +V>S Q

 S D=1

 Q

EDSCR ;

 NEW A,B

 F A=1:1 S B=$P(V,",",A) Q:B=""  I V=B S D=1

 Q

BPIP ;

 NEW A,M,S,D

 I X'["," K X Q

 S A=$P(X,",")

 I A]"",A'?1.3N1"-"1.3N K X Q

 S A=$P(X,",",2)

 I A]"",A'?1.3N1"-"1.3N K X Q

 S M=$P(^APCLVGMS(APCLMTVG,0),U)

 S A=X

 S S=$P(A,",",1) I S]"" D  Q:'$D(X)

 .S X=$P(S,"-",1) I X<20!(X>275) K X Q

 .S X=$P(S,"-",2) I X<20!(X>275) K X Q

 S D=$P(A,",",2) I D]"" D  Q:'$D(X)

 .S X=$P(D,"-",1) I X<20!(X>200) K X Q

 .S X=$P(D,"-",2) I X<20!(X>200) K X Q

 S X=A

 Q

BPSCR ;

 NEW S,E,A,B,F,Z

 S E=0,F=0

 S S=$P(R,",",1) I S]"" D

 .S A=$P(S,"-",1) I $P(V,"/",1)<A Q

 .S A=$P(S,"-",2) I $P(V,"/",1)>A Q

 .S E=1

 I S]"",'E Q

 S E=1

 S Z=$P(R,",",2) I Z]"" D

 .S B=$P(Z,"-",1) I $P(V,"/",2)<B Q

 .S B=$P(Z,"-",2) I $P(V,"/",2)>B Q

 .S F=1

 I Z]"",'F Q

 I E,F S D=1 Q

 Q

PRIP ;

 NEW A,M,S,D

 S A=$$STRIP^XLFSTR(X," ")

 F S=1:1 S D=$P(A,",",S) Q:D=""  D

 .I D=1 Q

 .I D=2 Q

 .I D=3 Q

 .I D=4 Q

 .I D=5 Q

 .I D=6 Q

 .I D=7 Q

 .I D=8 Q

 .I D=9 Q

 .I D="U" Q

 .K X

 S APCLVR=A

 Q

PRSCR ;

 NEW A,B

 F A=1:1 S B=$P(V,",",A) Q:B=""  I V=B S D=1

 Q

OTHSPEC ;EP - other speciaty providers

 ;get provider type and list of providers

 W !,"With this selection item you will be prompted to enter which specialty "

 W !,"provider type you want included in the search.  When you select a provider "

 W !,"type you will be asked to include all providers in that category or to "

 W !,"just include certain providers.",!

GETTYPE ;

 NEW APCLPROV,APCLPRVN,APCLPRVD

 K APCLMSR

GETTYPE1 ;

 W !

 K DIC S DIC="^BDPTCAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA

 I Y=-1,'$D(APCLMSR) W !,"no provider types selected." D PAUSE^APCLVL01 Q

 I Y=-1 D SETRPT Q

 S APCLMT=+Y,APCLMSR(APCLMT)="",APCLMTT=$P(^BDPTCAT(APCLMT,0),U)

 ;now get value

 S DIR(0)="S^A:ANY/ALL "_APCLMTT_" Providers;S:Selected Set of "_APCLMTT_" Providers",DIR("A")="Include which "_APCLMTT_" Providers" KILL DA

 S DIR("B")="A" D ^DIR KILL DIR

 I $D(DIRUT) S APCLMSR(APCLMT)="" W !,"skipping provider type ",APCLMTT K APCLMSR(APCLMT) G GETTYPE1

 I Y="A" G GETTYPE1

PROV ;GET VALUE RANGE

 K APCLPROV,APCLPRVN,APCLPRVD

 S X="PRIMARY CARE PROVIDER",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" G GETTYPE1

 D PEP^AMQQGTX0(+Y,"APCLPROV(")

 I '$D(APCLPROV) W !,"no providers selected, will search for all ",APCLMTT," providers." G GETTYPE1

 I $D(APCLPROV("*")) W !,"all ",APCLMTT," will be searched for" K APCLPROV G GETTYPE1

 S APCLVR=""

 S Y=0 F  S Y=$O(APCLPROV(Y)) Q:Y'=+Y  D

 .I APCLVR="" S APCLVR=Y Q

 .S APCLVR=APCLVR_","_Y

 S APCLMSR(APCLMT)=APCLVR

 G GETTYPE1

 ;

OTHSPECS ;EP

 NEW D,G

 ;S D=$S(APCLPTVS="P":DT,1:$P($P(APCLVREC,U),"."))

 K D

 D ALLDPVG^BDPAPI(DFN,,.D)

 I '$D(D) Q

 NEW A,B,C,R,E

 S G=0

 S A=0 F  S A=$O(D(A)) Q:A'=+A!(G=1)  I $D(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A)) D

 .S B=$O(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A,0))

 .S R=$P(^APCLVRPT(APCLRPT,11,APCLI,11,B,0),U,2)

 .I R="" S G=1 Q  ;patient has a provider of this category

 .F E=1:1 S C=$P(R,",",E) Q:C=""!(G)  I $P(D(A),U,3)=C S G=1

 .Q

 I G S X=1,X(1)=""

 Q

OTHSPED ;EP - other speciaty providers

 ;get provider type and list of providers

 W !,"With this selection item you will be prompted to enter which specialty "

 W !,"provider type you want included in the search.  When you select a provider "

 W !,"type you will then be asked the date range to search for date last update.",!

GTD ;

 NEW APCLPROV,APCLPRVN,APCLPRVD

 K APCLMSR

GTD1 ;

 W !

 K DIC S DIC="^BDPTCAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA

 I Y=-1,'$D(APCLMSR) W !,"no provider types selected." D PAUSE^APCLVL01 Q

 I Y=-1 D SETRPT Q

 S APCLMT=+Y,APCLMSR(APCLMT)="",APCLMTT=$P(^BDPTCAT(APCLMT,0),U)

 ;

DATE ;GET VALUE RANGE

BD ;

 W ! S DIR(0)="D^::EP",DIR("A")="Enter beginning Update Date for Search" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) W !,"No date selected.  Choose again." K APCLMSR(APCLMT) G GTD

 S APCLBDAT=Y

ED ;get ending date

 W ! S DIR(0)="D^"_APCLBDAT_"::EP",DIR("A")="Enter ending Update Date for Search" S Y=APCLBDAT D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G BD

 S APCLEDAT=Y

 S APCLMSR(APCLMT)=APCLBDAT_":"_APCLEDAT

 G GTD1

 ;

SETRPT1 ;

 S (X,Y)=0 F  S X=$O(APCLMSR(X)) Q:X'=+X  D

 .S Y=Y+1

 .S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""

 .S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,Y,0)=X_"^"_APCLMSR(X)

 .S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X,Y)=""

 .S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_Y_"^"_Y

 Q

OTHSPECD ;EP

 NEW D,G

 K D

 D ALLDPVG^BDPAPI(DFN,,.D)

 I '$D(D) Q

 NEW A,B,C,R,E,B,T

 S G=0

 S A=0 F  S A=$O(D(A)) Q:A'=+A!(G=1)  I $D(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A)) D

 .S B=$O(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A,0))

 .S R=$P(^APCLVRPT(APCLRPT,11,APCLI,11,B,0),U,2)

 .I R="" S G=1 Q  ;patient has a provider of this category

 .S B=$P(R,":",1),E=$P(R,":",2)

 .S T=$P(D(A),U,5)

 .I B>T Q

 .I E<T Q

 .S G=1

 .Q

 I G S X=1,X(1)=""

 Q

OTHSPECU ;EP

 NEW D,G

 K D

 D ALLDPVG^BDPAPI(DFN,,.D)

 I '$D(D) Q

 NEW A,B,C,R,E

 S G=0

 S A=0 F  S A=$O(D(A)) Q:A'=+A!(G=1)  I $D(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A)) D

 .S B=$O(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A,0))

 .S R=$P(^APCLVRPT(APCLRPT,11,APCLI,11,B,0),U,2)

 .I R="" S G=1 Q  ;patient has a provider of this category

 .F E=1:1 S C=$P(R,",",E) Q:C=""!(G)  I $P(D(A),U,6)=C S G=1

 .Q

 I G S X=1,X(1)=""

 Q

OTHSPEU ;EP - other speciaty providers

 ;get provider type and list of providers

 W !,"With this selection item you will be prompted to enter which specialty "

 W !,"provider type you want included in the search.  When you select a provider "

 W !,"type you will be asked to include all users who last updated that provider"

 W !,"or to include on a selected set of users",!

GTU ;

 NEW APCLPROV,APCLPRVN,APCLPRVD

 K APCLMSR

GTU1 ;

 W !

 K DIC S DIC="^BDPTCAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA

 I Y=-1,'$D(APCLMSR) W !,"no provider types selected." D PAUSE^APCLVL01 Q

 I Y=-1 D SETRPT Q

 S APCLMT=+Y,APCLMSR(APCLMT)="",APCLMTT=$P(^BDPTCAT(APCLMT,0),U)

 ;now get value

 S DIR(0)="S^A:ANY/ALL "_APCLMTT_" Users who Updated the Provider;S:Selected Set of "_APCLMTT_" Users who Updated the Provider",DIR("A")="Include which Users who Updated "_APCHMTT KILL DA

 S DIR("B")="A" D ^DIR KILL DIR

 I $D(DIRUT) S APCLMSR(APCLMT)="" W !,"skipping provider type ",APCLMTT K APCLMSR(APCLMT) G GTU1

 I Y="A" G GTU1

PU ;GET VALUE RANGE

 K APCLPROV,APCLPRVN,APCLPRVD

 S X="PRIMARY CARE PROVIDER",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" G GTU1

 D PEP^AMQQGTX0(+Y,"APCLPROV(")

 I '$D(APCLPROV) W !,"no users selected, will search for all ",APCLMTT," users." G GTU1

 I $D(APCLPROV("*")) W !,"all ",APCLMTT," will be searched for" K APCLPROV G GTU1

 S APCLVR=""

 S Y=0 F  S Y=$O(APCLPROV(Y)) Q:Y'=+Y  D

 .I APCLVR="" S APCLVR=Y Q

 .S APCLVR=APCLVR_","_Y

 S APCLMSR(APCLMT)=APCLVR

 G GTU1

 ;

APCLVL03  ; IHS/CMI/LAB - SCREEN LOGIC ; 

 +1       ;;2.0;IHS PCC SUITE;**2,4,7**;MAY 14, 2009

 +2       ;

MEAS      ;EP - measurements and values

 +1       ;get measurement type and value range and store as T_U_RANGE

 +2        WRITE !,"With this selection item you will be prompted to enter which measurement types"

 +3        WRITE !,"you want included in the VGEN search.  When you select a measurement type you"

 +4        WRITE !,"will be asked to include all values of the measurement or to just include"

 +5        WRITE !,"a user specified range of values.",!

GETMEAS   ;

 +1        KILL APCLMSR

GETMEAS1  ;

 +1        WRITE !

 +2        KILL DIC

           SET DIC="^AUTTMSR("

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC,DA

 +3        IF Y=-1

               IF '$DATA(APCLMSR)

                   WRITE !,"no measurements selected."

                   DO PAUSE^APCLVL01

                   QUIT 

 +4        IF Y=-1

               DO SETRPT

               QUIT 

 +5        SET APCLMT=+Y

           SET APCLMSR(APCLMT)=""

           SET APCLMTT=$PIECE(^AUTTMSR(APCLMT,0),U)

 +6       ;now get value

 +7        SET DIR(0)="S^A:ANY/ALL "_APCLMTT_" Values;S:Selected Range of "_APCLMTT_" Values"

           SET DIR("A")="Include which "_APCLMTT_" Values"

           KILL DA

 +8        SET DIR("B")="A"

           DO ^DIR

           KILL DIR

 +9        IF $DATA(DIRUT)

               SET APCLMSR(APCLMT)=""

               WRITE !,"skipping measurement ",APCLMTT

               KILL APCLMSR(APCLMT)

               GOTO GETMEAS1

 +10       IF Y="A"

               GOTO GETMEAS1

MVAL      ;GET VALUE RANGE

 +1        SET DIR(0)="F^1:999"

           SET DIR("A")="Enter the value range for "_APCLMTT

 +2        SET APCLMTVG=$ORDER(^APCLVGMS("B",APCLMT,0))

 +3        IF 'APCLMTVG

               WRITE !,"value range search not available for that measurement, all values will be included."

               GOTO GETMEAS1

 +4        SET DIR("?")="Enter the value range for "_APCLMTT

 +5        SET X=0

           SET C=0

           FOR 

               SET X=$ORDER(^APCLVGMS(APCLMTVG,1,X))

               IF X'=+X

                   QUIT 

               SET C=C+1

               SET DIR("?",C)=^APCLVGMS(APCLMTVG,1,X,0)

 +6        KILL DA

           DO ^DIR

           KILL DIR

 +7        IF $DATA(DIRUT)

               KILL APCLMSR(APCLMT)

               GOTO GETMEAS1

 +8        SET (X,APCLVR)=Y

           XECUTE ^APCLVGMS(APCLMTVG,2)

 +9        IF '$DATA(X)

               WRITE !,"Invalid range for ",APCLMTT

               Begin DoDot:1

 +10               SET X=0

                   SET C=0

                   FOR 

                       SET X=$ORDER(^APCLVGMS(APCLMTVG,1,X))

                       IF X'=+X

                           QUIT 

                       WRITE !,^APCLVGMS(APCLMTVG,1,X,0)

               End DoDot:1

               GOTO MVAL

 +11       SET APCLMSR(APCLMT)=APCLVR

 +12       GOTO GETMEAS1

 +13      ;

SETRPT    ;

 +1        SET (X,Y)=0

           FOR 

               SET X=$ORDER(APCLMSR(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +2                SET Y=Y+1

 +3                SET ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT

                   SET ^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""

 +4                SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,Y,0)=X_"^"_APCLMSR(X)

 +5                SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X,Y)=""

 +6                SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_Y_"^"_Y

               End DoDot:1

 +7        QUIT 

HESCR     ;

 +1        IF V=R

               SET D=1

               QUIT 

 +2        QUIT 

EDIP      ;

 +1        NEW A,M,B,H,S

 +2        SET H=X

           SET S=""

 +3        SET A=$$STRIP^XLFSTR(X," ")

 +4        FOR B=1:1

               SET C=$PIECE(A,",",B)

               IF C=""

                   QUIT 

               Begin DoDot:1

 +5                SET X=C

                   XECUTE ^AUTTMSR($PIECE(^APCLVGMS(APCLMTVG,0),U),12)

                   IF '$DATA(X)

                       SET S=1

               End DoDot:1

 +6        IF S

               KILL X

               QUIT 

 +7        SET APCLVR=A

 +8        QUIT 

NUMIP     ;

 +1        NEW A,M

 +2        SET M=$PIECE(^APCLVGMS(APCLMTVG,0),U)

 +3        SET A=X

 +4        SET X=$PIECE(A,"-",1)

           XECUTE ^AUTTMSR(M,12)

           IF '$DATA(X)

               QUIT 

 +5        SET X=$PIECE(A,"-",2)

           XECUTE ^AUTTMSR(M,12)

           IF '$DATA(X)

               QUIT 

 +6        SET X=A

 +7        QUIT 

MSRSCR    ;

 +1        NEW A,B,C,D,R,F,S,E,G

 +2        SET Y=0

           FOR 

               SET Y=$ORDER(^AUPNVMSR("AD",APCLVIEN,Y))

               IF Y'=+Y!(X=1)

                   QUIT 

               IF '$PIECE($GET(^AUPNVMSR(Y,2)),U,1)

                   SET A=$PIECE(^AUPNVMSR(Y,0),U,1)

                   IF $DATA(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A))

                       Begin DoDot:1

 +3       ;check value if need be

 +4                        SET B=$ORDER(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A,0))

 +5                        SET R=$PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,B,0),U,2)

 +6                        IF R=""

                               SET X=1

                               SET X(1)=""

                               QUIT 

 +7                        SET V=$PIECE(^AUPNVMSR(Y,0),U,4)

 +8                        SET C=$PIECE(^AUTTMSR(A,0),U)

 +9                        SET E=$ORDER(^APCLVGMS("B",A,0))

 +10                       SET G=$PIECE(^APCLVGMS(E,0),U,2)

 +11                       KILL D

 +12                       IF G

                               DO NUMSCR

                               IF 1

 +13                      IF '$TEST

                               DO @(C_"SCR")

 +14                       IF '$DATA(D)

                               QUIT 

 +15                       SET X=1

                           SET X(1)=""

 +16                       QUIT 

                       End DoDot:1

 +17       QUIT 

NUMSCR    ;

 +1        SET F=$PIECE(R,"-")

           SET S=$PIECE(R,"-",2)

 +2        IF +V<F

               QUIT 

 +3        IF +V>S

               QUIT 

 +4        SET D=1

 +5        QUIT 

EDSCR     ;

 +1        NEW A,B

 +2        FOR A=1:1

               SET B=$PIECE(V,",",A)

               IF B=""

                   QUIT 

               IF V=B

                   SET D=1

 +3        QUIT 

BPIP      ;

 +1        NEW A,M,S,D

 +2        IF X'[","

               KILL X

               QUIT 

 +3        SET A=$PIECE(X,",")

 +4        IF A]""

               IF A'?1.3N1"-"1.3N

                   KILL X

                   QUIT 

 +5        SET A=$PIECE(X,",",2)

 +6        IF A]""

               IF A'?1.3N1"-"1.3N

                   KILL X

                   QUIT 

 +7        SET M=$PIECE(^APCLVGMS(APCLMTVG,0),U)

 +8        SET A=X

 +9        SET S=$PIECE(A,",",1)

           IF S]""

               Begin DoDot:1

 +10               SET X=$PIECE(S,"-",1)

                   IF X<20!(X>275)

                       KILL X

                       QUIT 

 +11               SET X=$PIECE(S,"-",2)

                   IF X<20!(X>275)

                       KILL X

                       QUIT 

               End DoDot:1

               IF '$DATA(X)

                   QUIT 

 +12       SET D=$PIECE(A,",",2)

           IF D]""

               Begin DoDot:1

 +13               SET X=$PIECE(D,"-",1)

                   IF X<20!(X>200)

                       KILL X

                       QUIT 

 +14               SET X=$PIECE(D,"-",2)

                   IF X<20!(X>200)

                       KILL X

                       QUIT 

               End DoDot:1

               IF '$DATA(X)

                   QUIT 

 +15       SET X=A

 +16       QUIT 

BPSCR     ;

 +1        NEW S,E,A,B,F,Z

 +2        SET E=0

           SET F=0

 +3        SET S=$PIECE(R,",",1)

           IF S]""

               Begin DoDot:1

 +4                SET A=$PIECE(S,"-",1)

                   IF $PIECE(V,"/",1)<A

                       QUIT 

 +5                SET A=$PIECE(S,"-",2)

                   IF $PIECE(V,"/",1)>A

                       QUIT 

 +6                SET E=1

               End DoDot:1

 +7        IF S]""

               IF 'E

                   QUIT 

 +8        SET E=1

 +9        SET Z=$PIECE(R,",",2)

           IF Z]""

               Begin DoDot:1

 +10               SET B=$PIECE(Z,"-",1)

                   IF $PIECE(V,"/",2)<B

                       QUIT 

 +11               SET B=$PIECE(Z,"-",2)

                   IF $PIECE(V,"/",2)>B

                       QUIT 

 +12               SET F=1

               End DoDot:1

 +13       IF Z]""

               IF 'F

                   QUIT 

 +14       IF E

               IF F

                   SET D=1

                   QUIT 

 +15       QUIT 

PRIP      ;

 +1        NEW A,M,S,D

 +2        SET A=$$STRIP^XLFSTR(X," ")

 +3        FOR S=1:1

               SET D=$PIECE(A,",",S)

               IF D=""

                   QUIT 

               Begin DoDot:1

 +4                IF D=1

                       QUIT 

 +5                IF D=2

                       QUIT 

 +6                IF D=3

                       QUIT 

 +7                IF D=4

                       QUIT 

 +8                IF D=5

                       QUIT 

 +9                IF D=6

                       QUIT 

 +10               IF D=7

                       QUIT 

 +11               IF D=8

                       QUIT 

 +12               IF D=9

                       QUIT 

 +13               IF D="U"

                       QUIT 

 +14               KILL X

               End DoDot:1

 +15       SET APCLVR=A

 +16       QUIT 

PRSCR     ;

 +1        NEW A,B

 +2        FOR A=1:1

               SET B=$PIECE(V,",",A)

               IF B=""

                   QUIT 

               IF V=B

                   SET D=1

 +3        QUIT 

OTHSPEC   ;EP - other speciaty providers

 +1       ;get provider type and list of providers

 +2        WRITE !,"With this selection item you will be prompted to enter which specialty "

 +3        WRITE !,"provider type you want included in the search.  When you select a provider "