APCLDE4 ; IHS/CMI/LAB - list refusals ;
;;2.0;IHS PCC SUITE;**2,8,11**;MAY 14, 2009;Build 58
;
;
INFORM ;
W !,$$CTR($$USR)
W !,$$LOC()
W !!,"*Please Note: This DEPRESSION report is intended for advanced RPMS users"
W !,"who are experienced in building search templates and using Q-MAN."
W !!,$$CTR("TALLY AND LISTING OF PATIENT'S RECEIVING DEPRESSION SCREENING, INCLUDING REFUSALS",80)
W !,$$CTR("ONLY PATIENTS WHO ARE MEMBERS OF A USER DEFINED SEARCH TEMPLATE",80)
W !,$$CTR("ARE INCLUDED IN THIS REPORT",80)
W !!,"This report will tally and list all patients who are members of"
W !,"of a user defined search template. It will tally and list their latest"
W !,"DEPRESSION screening or a refusal documented in the time frame specified by "
W !,"the user. Depression Screening is defined as any of the following documented:"
W !?5,"- Depression Screening Exam (Exam code 36)"
W !?5,"- Measurements: PHQ2, PHQ9, PHQT"
W !?5,"- Diagnoses V79.0 (there are no ICD10 codes), 14.1 (Behavioral Hlth Code)"
W !?5,"- Education Topics: DEP-SCR"
W !?5,"- refusal of exam code 36"
W !,"This report will tally the patients by age, gender, screening exam result,"
W !,"provider (either exam provider, if available, or primary provider on the "
W !,"visit), clinic, date of screening, designated PCP, MH Provider, SS Provider"
W !,"and A/SA Provider."
W !," Notes: "
W !?10,"- the last screening/refusal for each patient is used. If a patient"
W !?10," was screened more than once in the time period, only the latest"
W !?10," is used in this report."
W !?10,"- this report will optionally, look at both PCC and the Behavioral"
W !?10," Health databases for evidence of screening/refusal"
W !?10,"- this is a tally of Patients, not visits or screenings"
W !
D PAUSE^APCLVL01
D XIT
S APCLEXC=$O(^AUTTEXAM("C",36,0))
I 'APCLEXC W !!,"Exam code 36 is missing from the EXAM table. Cannot run report.",! H 3 D XIT Q
;
DATES K APCLED,APCLBD
W !,"Please enter the date range during which the screening was done.",!,"To get all screenings ever put in a long date range like 01/01/1980 ",!,"to the present date.",!
K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date for Screening"
D ^DIR Q:Y<1 S APCLBD=Y
K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date for Screening"
D ^DIR Q:Y<1 S APCLED=Y
;
I APCLED<APCLBD D G DATES
. W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
;
STMP ;
S APCLSEAT=""
W ! S DIC("S")="I $P(^(0),U,4)=9000001!($P(^(0),U,4)=2)" S DIC="^DIBT(",DIC("A")="Enter Patient SEARCH TEMPLATE name: ",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DICR
I Y=-1 G DATES
S APCLSEAT=+Y
;
TALLY ;which items to tally
K APCLTALL
W !!,"Please select which items you wish to tally on this report:",!
W !?3,"0) Do not include any Tallies",?40,"6) Date of Screening"
W !?3,"1) Type/Result of Screening",?40,"7) Primary Provider on Visit"
W !?3,"2) Gender",?40,"8) Designated Primary Care Provider"
W !?3,"3) Age of Patient" ;,?40,"9) Designated SS Provider"
W !?3,"4) Provider who Screened" ;,?40,"10) Designated ASA/CD Provider"
W !?3,"5) Clinic" ;,?40,"11) Designated Primary Care Provider"
K DIR S DIR(0)="L^0:8",DIR("A")="Which items should be tallied",DIR("B")="" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G DATES
I Y="" G DATES
S APCLTALL=Y
S A=Y,C="" F I=1:1 S C=$P(A,",",I) Q:C="" S APCLTALL(C)=""
EXCL ;
S APCLEXPC=""
W !!,"Would you like to include screenings recorded in the Behavioral Clinics"
W !,"Mental Health (14); DEPRESSION and Substance Abuse (43), Medical Social"
S DIR(0)="Y",DIR("A")="Services, Behavioral Health (C4) and Telebehavioral Health (C9): ",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G DATES
S APCLEXPC=Y
LIST ;
S APCLLIST=""
W !
S DIR(0)="Y",DIR("A")="Would you like to include a list of patients screened",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G DATES
S APCLLIST=Y
I 'APCLLIST G ZIS
LIST1 ;
S APCLSORT=""
W !
S DIR(0)="S^H:Health Record Number;N:Patient Name;P:Provider who screened;C:Clinic;R:Result of Exam;D:Date Screened;A:Age of Patient at Screening;G:Gender of Patient;T:Terminal Digit HRN"
S DIR("A")="How would you like the list to be sorted",DIR("B")="H"
KILL DA D ^DIR KILL DIR
I $D(DIRUT) G LIST
S APCLSORT=Y
DP ;
S APCLDP=""
W !
S DIR(0)="Y",DIR("A")="Display the Patient's Designated Providers on the list",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G LIST
S APCLDP=Y
ZIS ;
S XBRP="PRINT^APCLDE4P",XBRC="PROC^APCLDE4",XBRX="XIT^APCLDE4",XBNS="APC"
D ^XBDBQUE
D XIT
Q
XIT ;
D EN^XBVK("APC")
D ^XBFMK
Q
PROC ;
S APCLCNT=0
S APCLH=$H,APCLJ=$J
K ^XTMP("APCLDE4",APCLJ,APCLH)
D XTMP^APCLOSUT("APCLDE4","DEPRESSION SCREENING REPORT")
;now go through BH
S DFN=0 F S DFN=$O(^DIBT(APCLSEAT,1,DFN)) Q:DFN'=+DFN D
.;Q:'$$ALLOWP^APCUTIL(DUZ,DFN) ;allowed to see this patient?
.S APCALSC="" I APCLEXPC S APCALSC=$$BHALCS^APCLDE1(DFN,APCLBD,APCLED),APCPFI="BH" ;include refusals
.S APCPCALS="" S APCPCALS=$$PCCALCS^APCLDE1(DFN,APCLBD,APCLED) ;include refusals
.I $P(APCPCALS,U,1)>$P(APCALSC,U,1) S APCALSC=APCPCALS,APCPFI="PCC"
.S APCLEFS="" S APCLEFS=$$REFUSAL^APCLDE1(DFN,9999999.15,$O(^AUTTEXAM("C",36,0)),APCLBD,APCLED)
.I $P(APCLEFS,U,1)>$P(APCALSC,U,1) S APCALSC=APCLEFS,APCPFI="PCC"
.I APCALSC="" Q ;no screenings
.S ^XTMP("APCLDE4",APCLJ,APCLH,"PTS",DFN)=APCALSC,$P(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",DFN),U,20)=APCPFI
Q
;
BHPPNAME(R) ;EP primary provider internal # from 200
NEW %,%1
S %=0,%1="" F S %=$O(^AMHRPROV("AD",R,%)) Q:%'=+% I $P(^AMHRPROV(%,0),U,4)="P" S %1=$P(^AMHRPROV(%,0),U),%1=$P($G(^VA(200,%1,0)),U)
I %1]"" Q %1
Q "UNKNOWN"
SPRV(E) ;
I $P($G(^AUPNVXAM(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.13,E,1204)
Q "UNKNOWN"
PRVREF(R) ;
I $P($G(^AUPNPREF(R,12)),U,4)]"" Q $$VAL^XBDIQ1(9000022,R,1204)
Q "UNKNOWN"
PPV(V) ;
NEW %
S %=$$PRIMPROV^APCLV(V)
I %]"" Q %
Q "UNKNOWN"
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:IO'=IO(0)
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
W !
S DIR("A")="End of Report. Press Enter",DIR(0)="E" D ^DIR
Q
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
APCLDE4 ; IHS/CMI/LAB - list refusals ;
+1 ;;2.0;IHS PCC SUITE;**2,8,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;
INFORM ;
+1 WRITE !,$$CTR($$USR)
+2 WRITE !,$$LOC()
+3 WRITE !!,"*Please Note: This DEPRESSION report is intended for advanced RPMS users"
+4 WRITE !,"who are experienced in building search templates and using Q-MAN."
+5 WRITE !!,$$CTR("TALLY AND LISTING OF PATIENT'S RECEIVING DEPRESSION SCREENING, INCLUDING REFUSALS",80)
+6 WRITE !,$$CTR("ONLY PATIENTS WHO ARE MEMBERS OF A USER DEFINED SEARCH TEMPLATE",80)
+7 WRITE !,$$CTR("ARE INCLUDED IN THIS REPORT",80)
+8 WRITE !!,"This report will tally and list all patients who are members of"
+9 WRITE !,"of a user defined search template. It will tally and list their latest"
+10 WRITE !,"DEPRESSION screening or a refusal documented in the time frame specified by "
+11 WRITE !,"the user. Depression Screening is defined as any of the following documented:"
+12 WRITE !?5,"- Depression Screening Exam (Exam code 36)"
+13 WRITE !?5,"- Measurements: PHQ2, PHQ9, PHQT"
+14 WRITE !?5,"- Diagnoses V79.0 (there are no ICD10 codes), 14.1 (Behavioral Hlth Code)"
+15 WRITE !?5,"- Education Topics: DEP-SCR"
+16 WRITE !?5,"- refusal of exam code 36"
+17 WRITE !,"This report will tally the patients by age, gender, screening exam result,"
+18 WRITE !,"provider (either exam provider, if available, or primary provider on the "
+19 WRITE !,"visit), clinic, date of screening, designated PCP, MH Provider, SS Provider"
+20 WRITE !,"and A/SA Provider."
+21 WRITE !," Notes: "
+22 WRITE !?10,"- the last screening/refusal for each patient is used. If a patient"
+23 WRITE !?10," was screened more than once in the time period, only the latest"
+24 WRITE !?10," is used in this report."
+25 WRITE !?10,"- this report will optionally, look at both PCC and the Behavioral"
+26 WRITE !?10," Health databases for evidence of screening/refusal"
+27 WRITE !?10,"- this is a tally of Patients, not visits or screenings"
+28 WRITE !
+29 DO PAUSE^APCLVL01
+30 DO XIT
+31 SET APCLEXC=$ORDER(^AUTTEXAM("C",36,0))
+32 IF 'APCLEXC
WRITE !!,"Exam code 36 is missing from the EXAM table. Cannot run report.",!
HANG 3
DO XIT
QUIT
+33 ;
DATES KILL APCLED,APCLBD
+1 WRITE !,"Please enter the date range during which the screening was done.",!,"To get all screenings ever put in a long date range like 01/01/1980 ",!,"to the present date.",!
+2 KILL DIR
WRITE !
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Beginning Date for Screening"
+3 DO ^DIR
IF Y<1
QUIT
SET APCLBD=Y
+4 KILL DIR
SET DIR(0)="DO^:DT:EXP"
SET DIR("A")="Enter Ending Date for Screening"
+5 DO ^DIR
IF Y<1
QUIT
SET APCLED=Y
+6 ;
+7 IF APCLED<APCLBD
Begin DoDot:1
+8 WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
End DoDot:1
GOTO DATES
+9 ;
STMP ;
+1 SET APCLSEAT=""
+2 WRITE !
SET DIC("S")="I $P(^(0),U,4)=9000001!($P(^(0),U,4)=2)"
SET DIC="^DIBT("
SET DIC("A")="Enter Patient SEARCH TEMPLATE name: "
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DICR
+3 IF Y=-1
GOTO DATES
+4 SET APCLSEAT=+Y
+5 ;
TALLY ;which items to tally
+1 KILL APCLTALL
+2 WRITE !!,"Please select which items you wish to tally on this report:",!
+3 WRITE !?3,"0) Do not include any Tallies",?40,"6) Date of Screening"
+4 WRITE !?3,"1) Type/Result of Screening",?40,"7) Primary Provider on Visit"
+5 WRITE !?3,"2) Gender",?40,"8) Designated Primary Care Provider"
+6 ;,?40,"9) Designated SS Provider"
WRITE !?3,"3) Age of Patient"
+7 ;,?40,"10) Designated ASA/CD Provider"
WRITE !?3,"4) Provider who Screened"
+8 ;,?40,"11) Designated Primary Care Provider"
WRITE !?3,"5) Clinic"
+9 KILL DIR
SET DIR(0)="L^0:8"
SET DIR("A")="Which items should be tallied"
SET DIR("B")=""
KILL DA
DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
GOTO DATES
+11 IF Y=""
GOTO DATES
+12 SET APCLTALL=Y
+13 SET A=Y
SET C=""
FOR I=1:1
SET C=$PIECE(A,",",I)
IF C=""
QUIT
SET APCLTALL(C)=""
EXCL ;
+1 SET APCLEXPC=""
+2 WRITE !!,"Would you like to include screenings recorded in the Behavioral Clinics"
+3 WRITE !,"Mental Health (14); DEPRESSION and Substance Abuse (43), Medical Social"
+4 SET DIR(0)="Y"
SET DIR("A")="Services, Behavioral Health (C4) and Telebehavioral Health (C9): "
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
GOTO DATES
+6 SET APCLEXPC=Y
LIST ;
+1 SET APCLLIST=""
+2 WRITE !
+3 SET DIR(0)="Y"
SET DIR("A")="Would you like to include a list of patients screened"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO DATES
+5 SET APCLLIST=Y
+6 IF 'APCLLIST
GOTO ZIS
LIST1 ;
+1 SET APCLSORT=""
+2 WRITE !
+3 SET DIR(0)="S^H:Health Record Number;N:Patient Name;P:Provider who screened;C:Clinic;R:Result of Exam;D:Date Screened;A:Age of Patient at Screening;G:Gender of Patient;T:Terminal Digit HRN"
+4 SET DIR("A")="How would you like the list to be sorted"
SET DIR("B")="H"
+5 KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
GOTO LIST
+7 SET APCLSORT=Y
DP ;
+1 SET APCLDP=""
+2 WRITE !
+3 SET DIR(0)="Y"
SET DIR("A")="Display the Patient's Designated Providers on the list"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO LIST
+5 SET APCLDP=Y
ZIS ;
+1 SET XBRP="PRINT^APCLDE4P"
SET XBRC="PROC^APCLDE4"
SET XBRX="XIT^APCLDE4"
SET XBNS="APC"
+2 DO ^XBDBQUE
+3 DO XIT
+4 QUIT
XIT ;
+1 DO EN^XBVK("APC")
+2 DO ^XBFMK
+3 QUIT
PROC ;
+1 SET APCLCNT=0
+2 SET APCLH=$HOROLOG
SET APCLJ=$JOB
+3 KILL ^XTMP("APCLDE4",APCLJ,APCLH)
+4 DO XTMP^APCLOSUT("APCLDE4","DEPRESSION SCREENING REPORT")
+5 ;now go through BH
+6 SET DFN=0
FOR
SET DFN=$ORDER(^DIBT(APCLSEAT,1,DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+7 ;Q:'$$ALLOWP^APCUTIL(DUZ,DFN) ;allowed to see this patient?
+8 ;include refusals
SET APCALSC=""
IF APCLEXPC
SET APCALSC=$$BHALCS^APCLDE1(DFN,APCLBD,APCLED)
SET APCPFI="BH"
+9 ;include refusals
SET APCPCALS=""
SET APCPCALS=$$PCCALCS^APCLDE1(DFN,APCLBD,APCLED)
+10 IF $PIECE(APCPCALS,U,1)>$PIECE(APCALSC,U,1)
SET APCALSC=APCPCALS
SET APCPFI="PCC"
+11 SET APCLEFS=""
SET APCLEFS=$$REFUSAL^APCLDE1(DFN,9999999.15,$ORDER(^AUTTEXAM("C",36,0)),APCLBD,APCLED)
+12 IF $PIECE(APCLEFS,U,1)>$PIECE(APCALSC,U,1)
SET APCALSC=APCLEFS
SET APCPFI="PCC"
+13 ;no screenings
IF APCALSC=""
QUIT
+14 SET ^XTMP("APCLDE4",APCLJ,APCLH,"PTS",DFN)=APCALSC
SET $PIECE(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",DFN),U,20)=APCPFI
End DoDot:1
+15 QUIT
+16 ;
BHPPNAME(R) ;EP primary provider internal # from 200
+1 NEW %,%1
+2 SET %=0
SET %1=""
FOR
SET %=$ORDER(^AMHRPROV("AD",R,%))
IF %'=+%
QUIT
IF $PIECE(^AMHRPROV(%,0),U,4)="P"
SET %1=$PIECE(^AMHRPROV(%,0),U)
SET %1=$PIECE($GET(^VA(200,%1,0)),U)
+3 IF %1]""
QUIT %1
+4 QUIT "UNKNOWN"
SPRV(E) ;
+1 IF $PIECE($GET(^AUPNVXAM(E,12)),U,4)
QUIT $$VAL^XBDIQ1(9000010.13,E,1204)
+2 QUIT "UNKNOWN"
PRVREF(R) ;
+1 IF $PIECE($GET(^AUPNPREF(R,12)),U,4)]""
QUIT $$VAL^XBDIQ1(9000022,R,1204)
+2 QUIT "UNKNOWN"
PPV(V) ;
+1 NEW %
+2 SET %=$$PRIMPROV^APCLV(V)
+3 IF %]""
QUIT %
+4 QUIT "UNKNOWN"
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF IO'=IO(0)
QUIT
+3 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+4 NEW DIR
+5 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+6 WRITE !
+7 SET DIR("A")="End of Report. Press Enter"
SET DIR(0)="E"
DO ^DIR
+8 QUIT
+9 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
