AMHRAS1 ; IHS/CMI/LAB - list ALCOHOL ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
;
INFORM ;
W !,$$CTR($$USR)
W !,$$LOC()
W !!,$$CTR("TALLY AND LISTING OF PATIENTS RECEIVING ALCOHOL SCREENING,INCLUDING REFUSALS",80)
W !!,"This report will tally and optionally list all patients who have had "
W !,"ALCOHOL screening or a refusal documented in the time frame specified by "
W !,"the user. Alcohol Screening is defined as any of the following documented:"
W !?5,"- Alcohol Screening Exam (Exam code 35)"
W !?5,"- Measurements: AUDC, AUDT, CRFT"
W !?5,"- Health Factor with Alcohol/Drug Category (CAGE)"
W !?5,"- Diagnoses V79.1, 29.1"
W !?5,"- Education Topics: AOD-SCR, CD-SCR"
W !?5,"- CPT Codes: 99408, 99409, G0396, G0397, H0049"
W !?5,"- refusal of exam code 35"
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^AMHLEA,DBHUSR^AMHUTIL
D XIT
S AMHREXC=$O(^AUTTEXAM("C",35,0))
I 'AMHREXC W !!,"Exam code 35 is missing from the EXAM table. Cannot run report.",! H 3 D XIT Q
;
DATES K AMHRED,AMHRBD
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 AMHRBD=Y
K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date for Screening"
D ^DIR Q:Y<1 S AMHRED=Y
;
I AMHRED<AMHRBD D G DATES
. W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
;
TALLY ;which items to tally
K AMHRTALL
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 MH 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:11",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 AMHRTALL=Y
S A=Y,C="" F I=1:1 S C=$P(A,",",I) Q:C="" S AMHRTALL(C)=""
EXCL ;
S AMHREXPC=""
W !!,"Would you like to include ALCOHOL Screenings documented in the PCC clinical"
S DIR(0)="Y",DIR("A")="database",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G DATES
S AMHREXPC=Y
LIST ;
S AMHRLIST=""
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 AMHRLIST=Y
I 'AMHRLIST G ZIS
LIST1 ;
S AMHRSORT=""
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 AMHRSORT=Y
DP ;
S AMHRDP=""
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 AMHRDP=Y
DEMO ;
D DEMOCHK^AMHUTIL1(.AMHDEMO)
I AMHDEMO=-1 G DP
ZIS ;
S XBRP="PRINT^AMHRAS1P",XBRC="PROC^AMHRAS1",XBRX="XIT^AMHRAS1",XBNS="AMHR"
D ^XBDBQUE
D XIT
Q
XIT ;
D EN^XBVK("AMHR")
D ^XBFMK
Q
PROC ;
S AMHRCNT=0
S AMHRH=$H,AMHRJ=$J
K ^XTMP("AMHRAS1",AMHRJ,AMHRH)
D XTMP^AMHUTIL("AMHRAS1","ALCOHOL SCREENING REPORT")
;now go through BH
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D
.Q:'$$ALLOWP^AMHUTIL(DUZ,DFN) ;allowed to see this patient?
.Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))
.S AMHALSC=$$BHALCS(DFN,AMHRBD,AMHRED),AMHPFI="BH" ;include refusals
.S AMHPCALS="" I AMHREXPC S AMHPCALS=$$PCCALCS(DFN,AMHRBD,AMHRED) ;include refusals
.I $P(AMHPCALS,U,1)>$P(AMHALSC,U,1) S AMHALSC=AMHPCALS,AMHPFI="PCC"
.S AMHREFS="" I AMHREXPC S AMHREFS=$$REFUSAL(DFN,9999999.15,$O(^AUTTEXAM("C",35,0)),AMHRBD,AMHRED)
.I $P(AMHREFS,U,1)>$P(AMHALSC,U,1) S AMHALSC=AMHREFS,AMHPFI="PCC"
.I AMHALSC="" Q ;no screenings
.S ^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",DFN)=AMHALSC,$P(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",DFN),U,20)=AMHPFI
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")
;----------
BHALCS(P,BDATE,EDATE) ;EP - pass back last BH screening
I '$G(P) Q ""
I '$G(BDATE) Q ""
I '$G(EDATE) Q ""
;loop through all of this patient's visits in date range
NEW SDATE,X,V,D,R,M,E
S R=""
S SDATE=9999999-$$FMADD^XLFDT(EDATE,1),SDATE=SDATE_".9999"
F S SDATE=$O(^AMHREC("AE",P,SDATE)) Q:SDATE'=+SDATE!($P(SDATE,".")>(9999999-BDATE))!(R]"") D
.S V=0 F S V=$O(^AMHREC("AE",P,SDATE,V)) Q:V'=+V!(R]"") D
..Q:'$D(^AMHREC(V,0))
..Q:'$$ALLOWVI^AMHUTIL(DUZ,V)
..;get measurements AUDC, AUDT, CRFTT
..S X=0 F S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X!(R]"") D
...S M=$$VAL^XBDIQ1(9002011.12,X,.01)
...I M="AUDC"!(M="AUDT")!(M="CRFT") S R=$$BHRT(V,M,$P(^AMHRMSR(X,0),U,4),P,$$VALI^XBDIQ1(9002011.12,X,1204))
..I R]"" Q
..;get exam
..S E=$P($G(^AMHREC(V,14)),U,3)
..I E]"" S R=$$BHRT(V,"ALCOHOL SCREENING",$$VAL^XBDIQ1(9002011,V,1403),P,$P($G(^AMHREC(V,14)),U,4),$P($G(^AMHREC(V,16)),U,1))
..I R]"" Q
..S X=0 F S X=$O(^AMHRHF("AD",V,X)) Q:X'=+X!(R]"") D
...S M=$$VALI^XBDIQ1(9002011.08,X,.01)
...I $P(^AUTTHF($P(^AUTTHF(M,0),U,3),0),U)="ALCOHOL/DRUG" S R=$$BHRT(V,$$VAL^XBDIQ1(9002011.08,X,.01),"",P,$$VALI^XBDIQ1(9002011.08,X,.05),$P($G(^AMHRHF(V,811)),U,1))
..I R]"" Q
..S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(R]"") D
...S M=$$VAL^XBDIQ1(9002011.01,X,.01)
...I M="29.1"!(M="V79.1") S R=$$BHRT(V,M,"",P,$$VALI^XBDIQ1(9002011.01,X,1204))
..I R]"" Q
..S X=0 F S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X!(R]"") D
...S M=$$VAL^XBDIQ1(9002011.05,X,.01)
...I M="CD-SCR"!(M="AOD-SCR") S R=$$BHRT(V,M,"",P,$$VALI^XBDIQ1(9002011.05,X,.04),$P($G(^AMHREDU(V,11)),U,1))
..I R]"" Q
..S X=0 F S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X!(R]"") D
...S M=$$VALI^XBDIQ1(9002011.04,X,.01)
...Q:'$$ICD^ATXCHK(M,$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),1)
...S R=$$BHRT(V,"CPT: "_$$VAL^XBDIQ1(9002011.04,X,.01),"",P,"")
..I R]"" Q
Q R
BHRT(V,TYPE,RES,PAT,PROVSCRN,COMMENT) ;EP
S PROVSCRN=$G(PROVSCRN)
S COMMENT=$G(COMMENT)
NEW T,D
S (D,T)=$P($P(^AMHREC(V,0),U),".")
S $P(T,U,2)=TYPE_";"_RES
S $P(T,U,3)=$P(^DPT(PAT,0),U,2)
S $P(T,U,4)=$$AGE^AUPNPAT(PAT,D)
S $P(T,U,5)=$S($G(PROVSCRN)]"":$P(^VA(200,PROVSCRN,0),U),1:"UNKNOWN")
S $P(T,U,6)=$$VAL^XBDIQ1(9002011,V,.25)
S $P(T,U,7)=$$BHPPNAME(V)
S $P(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)
S $P(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)
S $P(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)
S $P(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)
S $P(T,U,13)=V
S $P(T,U,12)=COMMENT
S $P(T,U,15)=PAT
S $P(T,U,20)="BH"
Q T
;
PCCALCS(P,BDATE,EDATE) ;EP - get alcohol screening from pcc
I '$G(P) Q ""
I '$G(BDATE) Q ""
I '$G(EDATE) Q ""
NEW T
;S T=$$LASTALC^APCLAPI(P,BDATE,EDATE,"A")
NEW R,V,AMHRDATE,SDATE
S R=""
S SDATE=9999999-$$FMADD^XLFDT(EDATE,1),SDATE=SDATE_".9999"
F S SDATE=$O(^AUPNVSIT("AA",P,SDATE)) Q:SDATE'=+SDATE!($P(SDATE,".")>(9999999-BDATE))!(R]"") D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,SDATE,V)) Q:V'=+V!(R]"") D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$$ALLOWPCC^AMHUTIL(DUZ,V)
..S AMHRDATE=$P($P(^AUPNVSIT(V,0),U),".")
..S DFN=$P(^AUPNVSIT(V,0),U,5)
..Q:DFN=""
..Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
..S R=$$PCCSCR^AMHRAS2(V)
Q R
REFUSAL(PAT,F,I,B,E) ;EP
I '$G(PAT) Q ""
I '$G(F) Q ""
I '$G(I) Q ""
I $G(B)="" Q ""
I $G(E)="" Q ""
NEW T,X,Y,%DT S X=B,%DT="P" D ^%DT S B=Y
S X=E,%DT="P" D ^%DT S E=Y
S (X,T)="" F S X=$O(^AUPNPREF("AA",PAT,F,I,X)) Q:X'=+X!(T]"") S Y=0 F S Y=$O(^AUPNPREF("AA",PAT,F,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) D
.S T=D
.S $P(T,U,2)="REFUSED;"_$$VAL^XBDIQ1(9000022,Y,.07)
.S $P(T,U,3)=$P(^DPT(PAT,0),U,2)
.S $P(T,U,4)=$$AGE^AUPNPAT(PAT,D)
.S $P(T,U,5)=$$VAL^XBDIQ1(9000022,Y,1204) I $P(T,U,5)="" S $P(T,U,5)="UNKNOWN"
.S $P(T,U,6)="UNKNOWN"
.S $P(T,U,7)="UNKNOWN"
.S $P(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)
.S $P(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)
.S $P(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)
.S $P(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)
Q T
PCCV(S,PAT) ;EP
NEW T
S T=""
S $P(T,U)=$P(S,U)
S $P(T,U,2)=$P(S,U,2)_";"_$P(S,U,3)
S $P(T,U,3)=$P(^DPT(PAT,0),U,2)
S $P(T,U,4)=$$AGE^AUPNPAT(PAT,$P(S,U))
S $P(T,U,5)=$$SCRNPCC(S)
S $P(T,U,6)=$$VAL^XBDIQ1(9000010,$P(S,U,4),.08)
S $P(T,U,7)=$$PRIMPROV^APCLV($P(S,U,4),"N")
S $P(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)
S $P(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)
S $P(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)
S $P(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)
S $P(T,U,14)=$P(S,U,4)
S $P(T,U,15)=PAT
S $P(T,U,20)="PCC"
Q T
SCRNPCC(T) ;get screening provider based on v file
NEW S,F
S F=1202
I $P(T,U,5)=9000010.16!($P(T,U,5)=9000010.23) S F=".05"
S S=$$VAL^XBDIQ1($P(T,U,5),$P(T,U,6),F)
I S]"" Q S
Q "UNKNOWN"
AMHRAS1 ; IHS/CMI/LAB - list ALCOHOL ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
+3 ;
INFORM ;
+1 WRITE !,$$CTR($$USR)
+2 WRITE !,$$LOC()
+3 WRITE !!,$$CTR("TALLY AND LISTING OF PATIENTS RECEIVING ALCOHOL SCREENING,INCLUDING REFUSALS",80)
+4 WRITE !!,"This report will tally and optionally list all patients who have had "
+5 WRITE !,"ALCOHOL screening or a refusal documented in the time frame specified by "
+6 WRITE !,"the user. Alcohol Screening is defined as any of the following documented:"
+7 WRITE !?5,"- Alcohol Screening Exam (Exam code 35)"
+8 WRITE !?5,"- Measurements: AUDC, AUDT, CRFT"
+9 WRITE !?5,"- Health Factor with Alcohol/Drug Category (CAGE)"
+10 WRITE !?5,"- Diagnoses V79.1, 29.1"
+11 WRITE !?5,"- Education Topics: AOD-SCR, CD-SCR"
+12 WRITE !?5,"- CPT Codes: 99408, 99409, G0396, G0397, H0049"
+13 WRITE !?5,"- refusal of exam code 35"
+14 WRITE !,"This report will tally the patients by age, gender, screening exam result,"
+15 WRITE !,"provider (either exam provider, if available, or primary provider on the "
+16 WRITE !,"visit), clinic, date of screening, designated PCP, MH Provider, SS Provider"
+17 WRITE !,"and A/SA Provider."
+18 WRITE !," Notes: "
+19 WRITE !?10,"- the last screening/refusal for each patient is used. If a patient"
+20 WRITE !?10," was screened more than once in the time period, only the latest"
+21 WRITE !?10," is used in this report."
+22 WRITE !?10,"- this report will optionally, look at both PCC and the Behavioral"
+23 WRITE !?10," Health databases for evidence of screening/refusal"
+24 WRITE !?10,"- this is a tally of Patients, not visits or screenings"
+25 WRITE !
+26 DO PAUSE^AMHLEA
DO DBHUSR^AMHUTIL
+27 DO XIT
+28 SET AMHREXC=$ORDER(^AUTTEXAM("C",35,0))
+29 IF 'AMHREXC
WRITE !!,"Exam code 35 is missing from the EXAM table. Cannot run report.",!
HANG 3
DO XIT
QUIT
+30 ;
DATES KILL AMHRED,AMHRBD
+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 AMHRBD=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 AMHRED=Y
+6 ;
+7 IF AMHRED<AMHRBD
Begin DoDot:1
+8 WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
End DoDot:1
GOTO DATES
+9 ;
TALLY ;which items to tally
+1 KILL AMHRTALL
+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 MH Provider"
+6 WRITE !?3,"3) Age of Patient",?40,"9) Designated SS Provider"
+7 WRITE !?3,"4) Provider who Screened",?40,"10) Designated ASA/CD Provider"
+8 WRITE !?3,"5) Clinic",?40,"11) Designated Primary Care Provider"
+9 KILL DIR
SET DIR(0)="L^0:11"
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 AMHRTALL=Y
+13 SET A=Y
SET C=""
FOR I=1:1
SET C=$PIECE(A,",",I)
IF C=""
QUIT
SET AMHRTALL(C)=""
EXCL ;
+1 SET AMHREXPC=""
+2 WRITE !!,"Would you like to include ALCOHOL Screenings documented in the PCC clinical"
+3 SET DIR(0)="Y"
SET DIR("A")="database"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO DATES
+5 SET AMHREXPC=Y
LIST ;
+1 SET AMHRLIST=""
+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 AMHRLIST=Y
+6 IF 'AMHRLIST
GOTO ZIS
LIST1 ;
+1 SET AMHRSORT=""
+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 AMHRSORT=Y
DP ;
+1 SET AMHRDP=""
+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 AMHRDP=Y
DEMO ;
+1 DO DEMOCHK^AMHUTIL1(.AMHDEMO)
+2 IF AMHDEMO=-1
GOTO DP
ZIS ;
+1 SET XBRP="PRINT^AMHRAS1P"
SET XBRC="PROC^AMHRAS1"
SET XBRX="XIT^AMHRAS1"
SET XBNS="AMHR"
+2 DO ^XBDBQUE
+3 DO XIT
+4 QUIT
XIT ;
+1 DO EN^XBVK("AMHR")
+2 DO ^XBFMK
+3 QUIT
PROC ;
+1 SET AMHRCNT=0
+2 SET AMHRH=$HOROLOG
SET AMHRJ=$JOB
+3 KILL ^XTMP("AMHRAS1",AMHRJ,AMHRH)
+4 DO XTMP^AMHUTIL("AMHRAS1","ALCOHOL SCREENING REPORT")
+5 ;now go through BH
+6 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+7 ;allowed to see this patient?
IF '$$ALLOWP^AMHUTIL(DUZ,DFN)
QUIT
+8 IF $$DEMO^AMHUTIL1(DFN,$GET(AMHDEMO))
QUIT
+9 ;include refusals
SET AMHALSC=$$BHALCS(DFN,AMHRBD,AMHRED)
SET AMHPFI="BH"
+10 ;include refusals
SET AMHPCALS=""
IF AMHREXPC
SET AMHPCALS=$$PCCALCS(DFN,AMHRBD,AMHRED)
+11 IF $PIECE(AMHPCALS,U,1)>$PIECE(AMHALSC,U,1)
SET AMHALSC=AMHPCALS
SET AMHPFI="PCC"
+12 SET AMHREFS=""
IF AMHREXPC
SET AMHREFS=$$REFUSAL(DFN,9999999.15,$ORDER(^AUTTEXAM("C",35,0)),AMHRBD,AMHRED)
+13 IF $PIECE(AMHREFS,U,1)>$PIECE(AMHALSC,U,1)
SET AMHALSC=AMHREFS
SET AMHPFI="PCC"
+14 ;no screenings
IF AMHALSC=""
QUIT
+15 SET ^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",DFN)=AMHALSC
SET $PIECE(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",DFN),U,20)=AMHPFI
End DoDot:1
+16 QUIT
+17 ;
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 ;----------
BHALCS(P,BDATE,EDATE) ;EP - pass back last BH screening
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(BDATE)
QUIT ""
+3 IF '$GET(EDATE)
QUIT ""
+4 ;loop through all of this patient's visits in date range
+5 NEW SDATE,X,V,D,R,M,E
+6 SET R=""
+7 SET SDATE=9999999-$$FMADD^XLFDT(EDATE,1)
SET SDATE=SDATE_".9999"
+8 FOR
SET SDATE=$ORDER(^AMHREC("AE",P,SDATE))
IF SDATE'=+SDATE!($PIECE(SDATE,".")>(9999999-BDATE))!(R]"")
QUIT
Begin DoDot:1
+9 SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,SDATE,V))
IF V'=+V!(R]"")
QUIT
Begin DoDot:2
+10 IF '$DATA(^AMHREC(V,0))
QUIT
+11 IF '$$ALLOWVI^AMHUTIL(DUZ,V)
QUIT
+12 ;get measurements AUDC, AUDT, CRFTT
+13 SET X=0
FOR
SET X=$ORDER(^AMHRMSR("AD",V,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:3
+14 SET M=$$VAL^XBDIQ1(9002011.12,X,.01)
+15 IF M="AUDC"!(M="AUDT")!(M="CRFT")
SET R=$$BHRT(V,M,$PIECE(^AMHRMSR(X,0),U,4),P,$$VALI^XBDIQ1(9002011.12,X,1204))
End DoDot:3
+16 IF R]""
QUIT
+17 ;get exam
+18 SET E=$PIECE($GET(^AMHREC(V,14)),U,3)
+19 IF E]""
SET R=$$BHRT(V,"ALCOHOL SCREENING",$$VAL^XBDIQ1(9002011,V,1403),P,$PIECE($GET(^AMHREC(V,14)),U,4),$PIECE($GET(^AMHREC(V,16)),U,1))
+20 IF R]""
QUIT
+21 SET X=0
FOR
SET X=$ORDER(^AMHRHF("AD",V,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:3
+22 SET M=$$VALI^XBDIQ1(9002011.08,X,.01)
+23 IF $PIECE(^AUTTHF($PIECE(^AUTTHF(M,0),U,3),0),U)="ALCOHOL/DRUG"
SET R=$$BHRT(V,$$VAL^XBDIQ1(9002011.08,X,.01),"",P,$$VALI^XBDIQ1(9002011.08,X,.05),$PIECE($GET(^AMHRHF(V,811)),U,1))
End DoDot:3
+24 IF R]""
QUIT
+25 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:3
+26 SET M=$$VAL^XBDIQ1(9002011.01,X,.01)
+27 IF M="29.1"!(M="V79.1")
SET R=$$BHRT(V,M,"",P,$$VALI^XBDIQ1(9002011.01,X,1204))
End DoDot:3
+28 IF R]""
QUIT
+29 SET X=0
FOR
SET X=$ORDER(^AMHREDU("AD",V,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:3
+30 SET M=$$VAL^XBDIQ1(9002011.05,X,.01)
+31 IF M="CD-SCR"!(M="AOD-SCR")
SET R=$$BHRT(V,M,"",P,$$VALI^XBDIQ1(9002011.05,X,.04),$PIECE($GET(^AMHREDU(V,11)),U,1))
End DoDot:3
+32 IF R]""
QUIT
+33 SET X=0
FOR
SET X=$ORDER(^AMHRPROC("AD",V,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:3
+34 SET M=$$VALI^XBDIQ1(9002011.04,X,.01)
+35 IF '$$ICD^ATXCHK(M,$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),1)
QUIT
+36 SET R=$$BHRT(V,"CPT: "_$$VAL^XBDIQ1(9002011.04,X,.01),"",P,"")
End DoDot:3
+37 IF R]""
QUIT
End DoDot:2
End DoDot:1
+38 QUIT R
BHRT(V,TYPE,RES,PAT,PROVSCRN,COMMENT) ;EP
+1 SET PROVSCRN=$GET(PROVSCRN)
+2 SET COMMENT=$GET(COMMENT)
+3 NEW T,D
+4 SET (D,T)=$PIECE($PIECE(^AMHREC(V,0),U),".")
+5 SET $PIECE(T,U,2)=TYPE_";"_RES
+6 SET $PIECE(T,U,3)=$PIECE(^DPT(PAT,0),U,2)
+7 SET $PIECE(T,U,4)=$$AGE^AUPNPAT(PAT,D)
+8 SET $PIECE(T,U,5)=$SELECT($GET(PROVSCRN)]"":$PIECE(^VA(200,PROVSCRN,0),U),1:"UNKNOWN")
+9 SET $PIECE(T,U,6)=$$VAL^XBDIQ1(9002011,V,.25)
+10 SET $PIECE(T,U,7)=$$BHPPNAME(V)
+11 SET $PIECE(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)
+12 SET $PIECE(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)
+13 SET $PIECE(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)
+14 SET $PIECE(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)
+15 SET $PIECE(T,U,13)=V
+16 SET $PIECE(T,U,12)=COMMENT
+17 SET $PIECE(T,U,15)=PAT
+18 SET $PIECE(T,U,20)="BH"
+19 QUIT T
+20 ;
PCCALCS(P,BDATE,EDATE) ;EP - get alcohol screening from pcc
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(BDATE)
QUIT ""
+3 IF '$GET(EDATE)
QUIT ""
+4 NEW T
+5 ;S T=$$LASTALC^APCLAPI(P,BDATE,EDATE,"A")
+6 NEW R,V,AMHRDATE,SDATE
+7 SET R=""
+8 SET SDATE=9999999-$$FMADD^XLFDT(EDATE,1)
SET SDATE=SDATE_".9999"
+9 FOR
SET SDATE=$ORDER(^AUPNVSIT("AA",P,SDATE))
IF SDATE'=+SDATE!($PIECE(SDATE,".")>(9999999-BDATE))!(R]"")
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,SDATE,V))
IF V'=+V!(R]"")
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$$ALLOWPCC^AMHUTIL(DUZ,V)
QUIT
+13 SET AMHRDATE=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+14 SET DFN=$PIECE(^AUPNVSIT(V,0),U,5)
+15 IF DFN=""
QUIT
+16 IF '$$ALLOWP^AMHUTIL(DUZ,DFN)
QUIT
+17 SET R=$$PCCSCR^AMHRAS2(V)
End DoDot:2
End DoDot:1
+18 QUIT R
REFUSAL(PAT,F,I,B,E) ;EP
+1 IF '$GET(PAT)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 IF $GET(B)=""
QUIT ""
+5 IF $GET(E)=""
QUIT ""
+6 NEW T,X,Y,%DT
SET X=B
SET %DT="P"
DO ^%DT
SET B=Y
+7 SET X=E
SET %DT="P"
DO ^%DT
SET E=Y
+8 SET (X,T)=""
FOR
SET X=$ORDER(^AUPNPREF("AA",PAT,F,I,X))
IF X'=+X!(T]"")
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",PAT,F,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
Begin DoDot:1
+9 SET T=D
+10 SET $PIECE(T,U,2)="REFUSED;"_$$VAL^XBDIQ1(9000022,Y,.07)
+11 SET $PIECE(T,U,3)=$PIECE(^DPT(PAT,0),U,2)
+12 SET $PIECE(T,U,4)=$$AGE^AUPNPAT(PAT,D)
+13 SET $PIECE(T,U,5)=$$VAL^XBDIQ1(9000022,Y,1204)
IF $PIECE(T,U,5)=""
SET $PIECE(T,U,5)="UNKNOWN"
+14 SET $PIECE(T,U,6)="UNKNOWN"
+15 SET $PIECE(T,U,7)="UNKNOWN"
+16 SET $PIECE(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)
+17 SET $PIECE(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)
+18 SET $PIECE(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)
+19 SET $PIECE(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)
End DoDot:1
+20 QUIT T
PCCV(S,PAT) ;EP
+1 NEW T
+2 SET T=""
+3 SET $PIECE(T,U)=$PIECE(S,U)
+4 SET $PIECE(T,U,2)=$PIECE(S,U,2)_";"_$PIECE(S,U,3)
+5 SET $PIECE(T,U,3)=$PIECE(^DPT(PAT,0),U,2)
+6 SET $PIECE(T,U,4)=$$AGE^AUPNPAT(PAT,$PIECE(S,U))
+7 SET $PIECE(T,U,5)=$$SCRNPCC(S)
+8 SET $PIECE(T,U,6)=$$VAL^XBDIQ1(9000010,$PIECE(S,U,4),.08)
+9 SET $PIECE(T,U,7)=$$PRIMPROV^APCLV($PIECE(S,U,4),"N")
+10 SET $PIECE(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)
+11 SET $PIECE(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)
+12 SET $PIECE(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)
+13 SET $PIECE(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)
+14 SET $PIECE(T,U,14)=$PIECE(S,U,4)
+15 SET $PIECE(T,U,15)=PAT
+16 SET $PIECE(T,U,20)="PCC"
+17 QUIT T
SCRNPCC(T) ;get screening provider based on v file
+1 NEW S,F
+2 SET F=1202
+3 IF $PIECE(T,U,5)=9000010.16!($PIECE(T,U,5)=9000010.23)
SET F=".05"
+4 SET S=$$VAL^XBDIQ1($PIECE(T,U,5),$PIECE(T,U,6),F)
+5 IF S]""
QUIT S
+6 QUIT "UNKNOWN"
