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 "
+4 WRITE !,"type you will be asked to include all providers in that category or to "
+5 WRITE !,"just include certain providers.",!
GETTYPE ;
+1 NEW APCLPROV,APCLPRVN,APCLPRVD
+2 KILL APCLMSR
GETTYPE1 ;
+1 WRITE !
+2 KILL DIC
SET DIC="^BDPTCAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA
+3 IF Y=-1
IF '$DATA(APCLMSR)
WRITE !,"no provider types selected."
DO PAUSE^APCLVL01
QUIT
+4 IF Y=-1
DO SETRPT
QUIT
+5 SET APCLMT=+Y
SET APCLMSR(APCLMT)=""
SET APCLMTT=$PIECE(^BDPTCAT(APCLMT,0),U)
+6 ;now get value
+7 SET DIR(0)="S^A:ANY/ALL "_APCLMTT_" Providers;S:Selected Set of "_APCLMTT_" Providers"
SET DIR("A")="Include which "_APCLMTT_" Providers"
KILL DA
+8 SET DIR("B")="A"
DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
SET APCLMSR(APCLMT)=""
WRITE !,"skipping provider type ",APCLMTT
KILL APCLMSR(APCLMT)
GOTO GETTYPE1
+10 IF Y="A"
GOTO GETTYPE1
PROV ;GET VALUE RANGE
+1 KILL APCLPROV,APCLPRVN,APCLPRVD
+2 SET X="PRIMARY CARE PROVIDER"
SET DIC="^AMQQ(5,"
SET DIC(0)="FM"
SET DIC("S")="I $P(^(0),U,14)"
DO ^DIC
KILL DIC,DA
IF Y=-1
WRITE "OOPS - QMAN NOT CURRENT - QUITTING"
GOTO GETTYPE1
+3 DO PEP^AMQQGTX0(+Y,"APCLPROV(")
+4 IF '$DATA(APCLPROV)
WRITE !,"no providers selected, will search for all ",APCLMTT," providers."
GOTO GETTYPE1
+5 IF $DATA(APCLPROV("*"))
WRITE !,"all ",APCLMTT," will be searched for"
KILL APCLPROV
GOTO GETTYPE1
+6 SET APCLVR=""
+7 SET Y=0
FOR
SET Y=$ORDER(APCLPROV(Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+8 IF APCLVR=""
SET APCLVR=Y
QUIT
+9 SET APCLVR=APCLVR_","_Y
End DoDot:1
+10 SET APCLMSR(APCLMT)=APCLVR
+11 GOTO GETTYPE1
+12 ;
OTHSPECS ;EP
+1 NEW D,G
+2 ;S D=$S(APCLPTVS="P":DT,1:$P($P(APCLVREC,U),"."))
+3 KILL D
+4 DO ALLDPVG^BDPAPI(DFN,,.D)
+5 IF '$DATA(D)
QUIT
+6 NEW A,B,C,R,E
+7 SET G=0
+8 SET A=0
FOR
SET A=$ORDER(D(A))
IF A'=+A!(G=1)
QUIT
IF $DATA(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A))
Begin DoDot:1
+9 SET B=$ORDER(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A,0))
+10 SET R=$PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,B,0),U,2)
+11 ;patient has a provider of this category
IF R=""
SET G=1
QUIT
+12 FOR E=1:1
SET C=$PIECE(R,",",E)
IF C=""!(G)
QUIT
IF $PIECE(D(A),U,3)=C
SET G=1
+13 QUIT
End DoDot:1
+14 IF G
SET X=1
SET X(1)=""
+15 QUIT
OTHSPED ;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 "
+4 WRITE !,"type you will then be asked the date range to search for date last update.",!
GTD ;
+1 NEW APCLPROV,APCLPRVN,APCLPRVD
+2 KILL APCLMSR
GTD1 ;
+1 WRITE !
+2 KILL DIC
SET DIC="^BDPTCAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA
+3 IF Y=-1
IF '$DATA(APCLMSR)
WRITE !,"no provider types selected."
DO PAUSE^APCLVL01
QUIT
+4 IF Y=-1
DO SETRPT
QUIT
+5 SET APCLMT=+Y
SET APCLMSR(APCLMT)=""
SET APCLMTT=$PIECE(^BDPTCAT(APCLMT,0),U)
+6 ;
DATE ;GET VALUE RANGE
BD ;
+1 WRITE !
SET DIR(0)="D^::EP"
SET DIR("A")="Enter beginning Update Date for Search"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
WRITE !,"No date selected. Choose again."
KILL APCLMSR(APCLMT)
GOTO GTD
+3 SET APCLBDAT=Y
ED ;get ending date
+1 WRITE !
SET DIR(0)="D^"_APCLBDAT_"::EP"
SET DIR("A")="Enter ending Update Date for Search"
SET Y=APCLBDAT
DO DD^%DT
SET DIR("B")=Y
SET Y=""
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO BD
+3 SET APCLEDAT=Y
+4 SET APCLMSR(APCLMT)=APCLBDAT_":"_APCLEDAT
+5 GOTO GTD1
+6 ;
SETRPT1 ;
+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
OTHSPECD ;EP
+1 NEW D,G
+2 KILL D
+3 DO ALLDPVG^BDPAPI(DFN,,.D)
+4 IF '$DATA(D)
QUIT
+5 NEW A,B,C,R,E,B,T
+6 SET G=0
+7 SET A=0
FOR
SET A=$ORDER(D(A))
IF A'=+A!(G=1)
QUIT
IF $DATA(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A))
Begin DoDot:1
+8 SET B=$ORDER(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A,0))
+9 SET R=$PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,B,0),U,2)
+10 ;patient has a provider of this category
IF R=""
SET G=1
QUIT
+11 SET B=$PIECE(R,":",1)
SET E=$PIECE(R,":",2)
+12 SET T=$PIECE(D(A),U,5)
+13 IF B>T
QUIT
+14 IF E<T
QUIT
+15 SET G=1
+16 QUIT
End DoDot:1
+17 IF G
SET X=1
SET X(1)=""
+18 QUIT
OTHSPECU ;EP
+1 NEW D,G
+2 KILL D
+3 DO ALLDPVG^BDPAPI(DFN,,.D)
+4 IF '$DATA(D)
QUIT
+5 NEW A,B,C,R,E
+6 SET G=0
+7 SET A=0
FOR
SET A=$ORDER(D(A))
IF A'=+A!(G=1)
QUIT
IF $DATA(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A))
Begin DoDot:1
+8 SET B=$ORDER(^APCLVRPT(APCLRPT,11,APCLI,11,"B",A,0))
+9 SET R=$PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,B,0),U,2)
+10 ;patient has a provider of this category
IF R=""
SET G=1
QUIT
+11 FOR E=1:1
SET C=$PIECE(R,",",E)
IF C=""!(G)
QUIT
IF $PIECE(D(A),U,6)=C
SET G=1
+12 QUIT
End DoDot:1
+13 IF G
SET X=1
SET X(1)=""
+14 QUIT
OTHSPEU ;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 "
+4 WRITE !,"type you will be asked to include all users who last updated that provider"
+5 WRITE !,"or to include on a selected set of users",!
GTU ;
+1 NEW APCLPROV,APCLPRVN,APCLPRVD
+2 KILL APCLMSR
GTU1 ;
+1 WRITE !
+2 KILL DIC
SET DIC="^BDPTCAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA
+3 IF Y=-1
IF '$DATA(APCLMSR)
WRITE !,"no provider types selected."
DO PAUSE^APCLVL01
QUIT
+4 IF Y=-1
DO SETRPT
QUIT
+5 SET APCLMT=+Y
SET APCLMSR(APCLMT)=""
SET APCLMTT=$PIECE(^BDPTCAT(APCLMT,0),U)
+6 ;now get value
+7 SET DIR(0)="S^A:ANY/ALL "_APCLMTT_" Users who Updated the Provider;S:Selected Set of "_APCLMTT_" Users who Updated the Provider"
SET DIR("A")="Include which Users who Updated "_APCHMTT
KILL DA
+8 SET DIR("B")="A"
DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
SET APCLMSR(APCLMT)=""
WRITE !,"skipping provider type ",APCLMTT
KILL APCLMSR(APCLMT)
GOTO GTU1
+10 IF Y="A"
GOTO GTU1
PU ;GET VALUE RANGE
+1 KILL APCLPROV,APCLPRVN,APCLPRVD
+2 SET X="PRIMARY CARE PROVIDER"
SET DIC="^AMQQ(5,"
SET DIC(0)="FM"
SET DIC("S")="I $P(^(0),U,14)"
DO ^DIC
KILL DIC,DA
IF Y=-1
WRITE "OOPS - QMAN NOT CURRENT - QUITTING"
GOTO GTU1
+3 DO PEP^AMQQGTX0(+Y,"APCLPROV(")
+4 IF '$DATA(APCLPROV)
WRITE !,"no users selected, will search for all ",APCLMTT," users."
GOTO GTU1
+5 IF $DATA(APCLPROV("*"))
WRITE !,"all ",APCLMTT," will be searched for"
KILL APCLPROV
GOTO GTU1
+6 SET APCLVR=""
+7 SET Y=0
FOR
SET Y=$ORDER(APCLPROV(Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+8 IF APCLVR=""
SET APCLVR=Y
QUIT
+9 SET APCLVR=APCLVR_","_Y
End DoDot:1
+10 SET APCLMSR(APCLMT)=APCLVR
+11 GOTO GTU1
+12 ;
