APCLAL2 ; IHS/CMI/LAB - list refusals ;
;;2.0;IHS PCC SUITE;**2,4,11**;MAY 14, 2009;Build 58
;
;
INFORM ;
W !,$$CTR($$USR)
W !,$$LOC()
W !!,$$CTR("TALLY AND LISTING OF ALL VISITS W/ALCOHOL SCREENING",80)
W !!,"This report will tally and optionally list all visits on which ALCOHOL"
W !,"screening or a refusal was documented in the time frame specified by the"
W !,"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 (there are no ICD10 codes), 29.1 (Behavioral Hlth Code)"
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 visits by age, gender, screening 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,"- this report will optionally, look at both PCC and the Behavioral"
W !?10," Health clinics for evidence of screening/refusal"
W !?10,"- this is a tally of visits with a screening done, if a patient had"
W !?10," multiple screenings during the time period, all will be counted"
W !
D PAUSE^APCLVL01
D XIT
S APCREXC=$O(^AUTTEXAM("C",35,0))
I 'APCREXC W !!,"Exam code 35 is missing from the EXAM table. Cannot run report.",! H 3 D XIT Q
;
DATES K APCRED,APCRBD
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 APCRBD=Y
K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date for Screening"
D ^DIR Q:Y<1 S APCRED=Y
;
I APCRED<APCRBD D G DATES
. W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
;
TALLY ;which items to tally
K APCRTALL
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 APCRTALL=Y
S A=Y,C="" F I=1:1 S C=$P(A,",",I) Q:C="" S APCRTALL(C)=""
EXCL ;
S APCLEXBH=""
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 APCLEXBH=Y
S APCREXPC=1
LIST ;
S APCRLIST=""
W !
S DIR(0)="Y",DIR("A")="Would you like to include a list of visits w/screening done",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G DATES
S APCRLIST=Y
I 'APCRLIST G ZIS
LIST1 ;
S APCRSORT=""
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 APCRSORT=Y
ZIS ;
S XBRP="PRINT^APCLAL2P",XBRC="PROC^APCLAL2",XBRX="XIT^APCLAL2",XBNS="APC"
D ^XBDBQUE
D XIT
Q
XIT ;
D EN^XBVK("APC")
D ^XBFMK
Q
PROC ;
S APCRCNT=0
S APCRH=$H,APCRJ=$J
K ^XTMP("APCLAL2",APCRJ,APCRH)
D XTMP^AMHUTIL("APCLAL2","ALCOHOL SCREENING REPORT")
;now go through BH
S APCRSD=$$FMADD^XLFDT(APCRBD,-1),APCRSD=APCRSD_".9999"
I 'APCLEXBH G PCC
F S APCRSD=$O(^AMHREC("B",APCRSD)) Q:APCRSD'=+APCRSD!($P(APCRSD,".")>APCRED) D
.S APCRBIEN=0 F S APCRBIEN=$O(^AMHREC("B",APCRSD,APCRBIEN)) Q:APCRBIEN'=+APCRBIEN D
..S APCRDATE=$P(APCRSD,".")
..Q:'$D(^AMHREC(APCRBIEN,0))
..;Q:'$$ALLOWVI^AMHUTIL(DUZ,APCRBIEN)
..Q:APCRDATE>APCRED
..Q:APCRDATE<APCRBD
..S DFN=$P(^AMHREC(APCRBIEN,0),U,8)
..Q:DFN=""
..;Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
..S APCSCR=$$BHSCR(APCRBIEN)
..Q:APCSCR=""
..S APCRCNT=APCRCNT+1
..S ^XTMP("APCLAL2",APCRJ,APCRH,"PTS",DFN,APCRDATE)=""
..S ^XTMP("APCLAL2",APCRJ,APCRH,"VSTS",APCRCNT)=APCSCR
PCC ;
;Q:'APCREXPC
S APCRSD=$$FMADD^XLFDT(APCRBD,-1),APCRSD=APCRSD_".9999"
F S APCRSD=$O(^AUPNVSIT("B",APCRSD)) Q:APCRSD'=+APCRSD!($P(APCRSD,".")>APCRED) D
.S APCRBIEN=0 F S APCRBIEN=$O(^AUPNVSIT("B",APCRSD,APCRBIEN)) Q:APCRBIEN'=+APCRBIEN D
..S APCRDATE=$P(APCRSD,".")
..Q:'$D(^AUPNVSIT(APCRBIEN,0))
..I APCLEXBH Q:$D(^AMHREC("AVISIT",APCRBIEN)) ;visit is in BH
..;Q:'$$ALLOWPCC^AMHUTIL(DUZ,APCRBIEN)
..Q:APCRDATE>APCRED
..Q:APCRDATE<APCRBD
..S DFN=$P(^AUPNVSIT(APCRBIEN,0),U,5)
..Q:DFN=""
..I 'APCLEXBH S C=$$CLINIC^APCLV(APCRBIEN,"C") I C=14!(C=43)!(C=48)!(C="C4")!(C="C9") Q
..;Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
..S APCSCR=$$PCCSCR(APCRBIEN)
..Q:APCSCR=""
..S APCRCNT=APCRCNT+1
..S ^XTMP("APCLAL2",APCRJ,APCRH,"PTS",DFN,APCRDATE)=""
..S ^XTMP("APCLAL2",APCRJ,APCRH,"VSTS",APCRCNT)=APCSCR
;now go through refusals in pcc
S APCRRIEN=0 F S APCRRIEN=$O(^AUPNPREF(APCRRIEN)) Q:APCRRIEN'=+APCRRIEN D
.Q:'$D(^AUPNPREF(APCRRIEN,0))
.Q:$P(^AUPNPREF(APCRRIEN,0),U,5)'=9999999.15
.Q:$P(^AUPNPREF(APCRRIEN,0),U,6)'=APCREXC
.S APCRDATE=$P(^AUPNPREF(APCRRIEN,0),U,3)
.Q:APCRDATE=""
.Q:APCRDATE>APCRED
.Q:APCRDATE<APCRBD
.S DFN=$P(^AUPNPREF(APCRRIEN,0),U,2)
.I $D(^XTMP("APCLAL2",APCRJ,APCRH,"PTS",DFN,APCRDATE)) Q
.S APCRCNT=APCRCNT+1
.S ^XTMP("APCLAL2",APCRJ,APCRH,"PTS",DFN,APCRDATE)=""
.S T=APCRDATE
.S $P(T,U,2)="REFUSED;"_$$VAL^XBDIQ1(9000022,APCRRIEN,.07)
.S $P(T,U,3)=$P(^DPT(DFN,0),U,2)
.S $P(T,U,4)=$$AGE^AUPNPAT(DFN,APCRDATE)
.S $P(T,U,5)=$$VAL^XBDIQ1(9000022,APCRRIEN,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,DFN,.02)
.S $P(T,U,9)=$$VAL^XBDIQ1(9002011.55,DFN,.03)
.S $P(T,U,10)=$$VAL^XBDIQ1(9002011.55,DFN,.04)
.S $P(T,U,11)=$$VAL^XBDIQ1(9000001,DFN,.14)
.S $P(T,U,15)=DFN
.S $P(T,U,20)="PCC"
.S ^XTMP("APCLAL2",APCRJ,APCRH,"VSTS",APCRCNT)=T
Q
;
BHSCR(V) ;EP - is there a screening? return in R
;get measurements AUDC, AUDT, CRFTT
NEW R,X,M,P,E
S R=""
S P=$P(^AMHREC(V,0),U,8)
S X=0 F S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X D
.S M=$$VAL^XBDIQ1(9002011.12,X,.01)
.I M="AUDC"!(M="AUDT")!(M="CRFT") S R=$$BHRT^APCLAL1(V,M,$P(^AMHRMSR(X,0),U,4),P,$$VALI^XBDIQ1(9002011.12,X,1204))
I R]"" Q R
;get exam
S E=$P($G(^AMHREC(V,14)),U,3)
I E]"" S R=$$BHRT^APCLAL1(V,"ALCOHOL SCREENING EXAM",$$VAL^XBDIQ1(9002011,V,1403),P,$P($G(^AMHREC(V,14)),U,4),$P($G(^AMHREC(V,16)),U,1))
I R]"" Q R
;get health factor
S X=0 F S X=$O(^AMHRHF("AD",V,X)) Q:X'=+X 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^APCLAL1(V,$$VAL^XBDIQ1(9002011.08,X,.01),"",P,$$VALI^XBDIQ1(9002011.08,X,.05),$P($G(^AMHRHF(V,811)),U,1))
I R]"" Q R
;get pov
S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X D
.S M=$$VAL^XBDIQ1(9002011.01,X,.01)
.I M="29.1"!(M="V79.1") S R=$$BHRT^APCLAL1(V,M,"",P,$$VALI^XBDIQ1(9002011.01,X,1204))
I R]"" Q R
;get education
S X=0 F S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X D
.S M=$$VAL^XBDIQ1(9002011.05,X,.01)
.I M="CD-SCR"!(M="AOD-SCR") S R=$$BHRT^APCLAL1(V,M,"",P,$$VALI^XBDIQ1(9002011.05,X,.04),$P($G(^AMHREDU(V,11)),U,1))
I R]"" Q R
;get CPTs
S X=0 F S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X D
.S M=$$VALI^XBDIQ1(9002011.04,X,.01)
.Q:'$$ICD^ATXAPI(M,$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),1)
.S R=$$BHRT^APCLAL1(V,"CPT: "_$$VAL^XBDIQ1(9002011.04,X,.01),"",P,"")
I R]"" Q R
Q R
;
PCCSCR(V) ;EP - is there a screening? return in R
;get measurements AUDC, AUDT, CRFTT
NEW R,X,M,P,E
S R=""
S P=$P(^AUPNVSIT(V,0),U,5)
S D=$P($P(^AUPNVSIT(V,0),U),".")
S X=0 F S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X D
.Q:$P($G(^AUPNVMSR(X,2)),U,1) ;entered in error
.S M=$$VAL^XBDIQ1(9000010.01,X,.01)
.I M="AUDC"!(M="AUDT")!(M="CRFT") D
..S T=D_U_M_U_$$VAL^XBDIQ1(9000010.01,X,.04)_U_V_U_9000010.01_U_X
..S R=$$PCCV^APCLAL1(T,P)
I R]"" Q R
;get exam
S X=0 F S X=$O(^AUPNVXAM("AD",V,X)) Q:X'=+X D
.S M=$$VAL^XBDIQ1(9000010.13,X,.01)
.I M="ALCOHOL SCREENING" D
..S T=D_U_M_U_$$VAL^XBDIQ1(9000010.13,X,.04)_U_V_U_9000010.13_U_X
..S R=$$PCCV^APCLAL1(T,P)
I R]"" Q R
;get health factor
S X=0 F S X=$O(^AUPNVHF("AD",V,X)) Q:X'=+X D
.S M=$$VALI^XBDIQ1(9000010.23,X,.01)
.I $P(^AUTTHF($P(^AUTTHF(M,0),U,3),0),U)="ALCOHOL/DRUG" D
..S T=D_U_$$VAL^XBDIQ1(9000010.23,X,.01)_U_U_V_U_9000010.23_U_X
..S R=$$PCCV^APCLAL1(T,P)
I R]"" Q R
;get pov
S X=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X D
.S M=$$VAL^XBDIQ1(9000010.07,X,.01)
.I M="V79.1" D ;NO ICD10 CODES PER FRAN
..S T=D_U_M_U_U_V_U_9000010.07_U_X
..S R=$$PCCV^APCLAL1(T,P)
I R]"" Q R
;get education
S X=0 F S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X D
.S M=$$VAL^XBDIQ1(9000010.16,X,.01)
.I M="CD-SCR"!(M="AOD-SCR") D
..S T=D_U_M_U_U_V_U_9000010.16_U_X
..S R=$$PCCV^APCLAL1(T,P)
I R]"" Q R
;get CPTs
S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
.S M=$$VALI^XBDIQ1(9000010.18,X,.01)
.Q:'$$ICD^ATXAPI(M,$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),1)
.S T=D_U_"CPT: "_$$VAL^XBDIQ1(9000010.18,X,.01)_U_U_V_U_9000010.18_U_X
.S R=$$PCCV^APCLAL1(T,P)
I R]"" Q R
Q R
;
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")
;----------
APCLAL2 ; IHS/CMI/LAB - list refusals ;
+1 ;;2.0;IHS PCC SUITE;**2,4,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;
INFORM ;
+1 WRITE !,$$CTR($$USR)
+2 WRITE !,$$LOC()
+3 WRITE !!,$$CTR("TALLY AND LISTING OF ALL VISITS W/ALCOHOL SCREENING",80)
+4 WRITE !!,"This report will tally and optionally list all visits on which ALCOHOL"
+5 WRITE !,"screening or a refusal was documented in the time frame specified by the"
+6 WRITE !,"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 (there are no ICD10 codes), 29.1 (Behavioral Hlth Code)"
+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 visits by age, gender, screening 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,"- this report will optionally, look at both PCC and the Behavioral"
+20 WRITE !?10," Health clinics for evidence of screening/refusal"
+21 WRITE !?10,"- this is a tally of visits with a screening done, if a patient had"
+22 WRITE !?10," multiple screenings during the time period, all will be counted"
+23 WRITE !
+24 DO PAUSE^APCLVL01
+25 DO XIT
+26 SET APCREXC=$ORDER(^AUTTEXAM("C",35,0))
+27 IF 'APCREXC
WRITE !!,"Exam code 35 is missing from the EXAM table. Cannot run report.",!
HANG 3
DO XIT
QUIT
+28 ;
DATES KILL APCRED,APCRBD
+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 APCRBD=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 APCRED=Y
+6 ;
+7 IF APCRED<APCRBD
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 APCRTALL
+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 APCRTALL=Y
+13 SET A=Y
SET C=""
FOR I=1:1
SET C=$PIECE(A,",",I)
IF C=""
QUIT
SET APCRTALL(C)=""
EXCL ;
+1 SET APCLEXBH=""
+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 APCLEXBH=Y
+7 SET APCREXPC=1
LIST ;
+1 SET APCRLIST=""
+2 WRITE !
+3 SET DIR(0)="Y"
SET DIR("A")="Would you like to include a list of visits w/screening done"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO DATES
+5 SET APCRLIST=Y
+6 IF 'APCRLIST
GOTO ZIS
LIST1 ;
+1 SET APCRSORT=""
+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 APCRSORT=Y
ZIS ;
+1 SET XBRP="PRINT^APCLAL2P"
SET XBRC="PROC^APCLAL2"
SET XBRX="XIT^APCLAL2"
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 APCRCNT=0
+2 SET APCRH=$HOROLOG
SET APCRJ=$JOB
+3 KILL ^XTMP("APCLAL2",APCRJ,APCRH)
+4 DO XTMP^AMHUTIL("APCLAL2","ALCOHOL SCREENING REPORT")
+5 ;now go through BH
+6 SET APCRSD=$$FMADD^XLFDT(APCRBD,-1)
SET APCRSD=APCRSD_".9999"
+7 IF 'APCLEXBH
GOTO PCC
+8 FOR
SET APCRSD=$ORDER(^AMHREC("B",APCRSD))
IF APCRSD'=+APCRSD!($PIECE(APCRSD,".")>APCRED)
QUIT
Begin DoDot:1
+9 SET APCRBIEN=0
FOR
SET APCRBIEN=$ORDER(^AMHREC("B",APCRSD,APCRBIEN))
IF APCRBIEN'=+APCRBIEN
QUIT
Begin DoDot:2
+10 SET APCRDATE=$PIECE(APCRSD,".")
+11 IF '$DATA(^AMHREC(APCRBIEN,0))
QUIT
+12 ;Q:'$$ALLOWVI^AMHUTIL(DUZ,APCRBIEN)
+13 IF APCRDATE>APCRED
QUIT
+14 IF APCRDATE<APCRBD
QUIT
+15 SET DFN=$PIECE(^AMHREC(APCRBIEN,0),U,8)
+16 IF DFN=""
QUIT
+17 ;Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
+18 SET APCSCR=$$BHSCR(APCRBIEN)
+19 IF APCSCR=""
QUIT
+20 SET APCRCNT=APCRCNT+1
+21 SET ^XTMP("APCLAL2",APCRJ,APCRH,"PTS",DFN,APCRDATE)=""
+22 SET ^XTMP("APCLAL2",APCRJ,APCRH,"VSTS",APCRCNT)=APCSCR
End DoDot:2
End DoDot:1
PCC ;
+1 ;Q:'APCREXPC
+2 SET APCRSD=$$FMADD^XLFDT(APCRBD,-1)
SET APCRSD=APCRSD_".9999"
+3 FOR
SET APCRSD=$ORDER(^AUPNVSIT("B",APCRSD))
IF APCRSD'=+APCRSD!($PIECE(APCRSD,".")>APCRED)
QUIT
Begin DoDot:1
+4 SET APCRBIEN=0
FOR
SET APCRBIEN=$ORDER(^AUPNVSIT("B",APCRSD,APCRBIEN))
IF APCRBIEN'=+APCRBIEN
QUIT
Begin DoDot:2
+5 SET APCRDATE=$PIECE(APCRSD,".")
+6 IF '$DATA(^AUPNVSIT(APCRBIEN,0))
QUIT
+7 ;visit is in BH
IF APCLEXBH
IF $DATA(^AMHREC("AVISIT",APCRBIEN))
QUIT
+8 ;Q:'$$ALLOWPCC^AMHUTIL(DUZ,APCRBIEN)
+9 IF APCRDATE>APCRED
QUIT
+10 IF APCRDATE<APCRBD
QUIT
+11 SET DFN=$PIECE(^AUPNVSIT(APCRBIEN,0),U,5)
+12 IF DFN=""
QUIT
+13 IF 'APCLEXBH
SET C=$$CLINIC^APCLV(APCRBIEN,"C")
IF C=14!(C=43)!(C=48)!(C="C4")!(C="C9")
QUIT
+14 ;Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
+15 SET APCSCR=$$PCCSCR(APCRBIEN)
+16 IF APCSCR=""
QUIT
+17 SET APCRCNT=APCRCNT+1
+18 SET ^XTMP("APCLAL2",APCRJ,APCRH,"PTS",DFN,APCRDATE)=""
+19 SET ^XTMP("APCLAL2",APCRJ,APCRH,"VSTS",APCRCNT)=APCSCR
End DoDot:2
End DoDot:1
+20 ;now go through refusals in pcc
+21 SET APCRRIEN=0
FOR
SET APCRRIEN=$ORDER(^AUPNPREF(APCRRIEN))
IF APCRRIEN'=+APCRRIEN
QUIT
Begin DoDot:1
+22 IF '$DATA(^AUPNPREF(APCRRIEN,0))
QUIT
+23 IF $PIECE(^AUPNPREF(APCRRIEN,0),U,5)'=9999999.15
QUIT
+24 IF $PIECE(^AUPNPREF(APCRRIEN,0),U,6)'=APCREXC
QUIT
+25 SET APCRDATE=$PIECE(^AUPNPREF(APCRRIEN,0),U,3)
+26 IF APCRDATE=""
QUIT
+27 IF APCRDATE>APCRED
QUIT
+28 IF APCRDATE<APCRBD
QUIT
+29 SET DFN=$PIECE(^AUPNPREF(APCRRIEN,0),U,2)
+30 IF $DATA(^XTMP("APCLAL2",APCRJ,APCRH,"PTS",DFN,APCRDATE))
QUIT
+31 SET APCRCNT=APCRCNT+1
+32 SET ^XTMP("APCLAL2",APCRJ,APCRH,"PTS",DFN,APCRDATE)=""
+33 SET T=APCRDATE
+34 SET $PIECE(T,U,2)="REFUSED;"_$$VAL^XBDIQ1(9000022,APCRRIEN,.07)
+35 SET $PIECE(T,U,3)=$PIECE(^DPT(DFN,0),U,2)
+36 SET $PIECE(T,U,4)=$$AGE^AUPNPAT(DFN,APCRDATE)
+37 SET $PIECE(T,U,5)=$$VAL^XBDIQ1(9000022,APCRRIEN,1204)
IF $PIECE(T,U,5)=""
SET $PIECE(T,U,5)="UNKNOWN"
+38 SET $PIECE(T,U,6)="UNKNOWN"
+39 SET $PIECE(T,U,7)="UNKNOWN"
+40 SET $PIECE(T,U,8)=$$VAL^XBDIQ1(9002011.55,DFN,.02)
+41 SET $PIECE(T,U,9)=$$VAL^XBDIQ1(9002011.55,DFN,.03)
+42 SET $PIECE(T,U,10)=$$VAL^XBDIQ1(9002011.55,DFN,.04)
+43 SET $PIECE(T,U,11)=$$VAL^XBDIQ1(9000001,DFN,.14)
+44 SET $PIECE(T,U,15)=DFN
+45 SET $PIECE(T,U,20)="PCC"
+46 SET ^XTMP("APCLAL2",APCRJ,APCRH,"VSTS",APCRCNT)=T
End DoDot:1
+47 QUIT
+48 ;
BHSCR(V) ;EP - is there a screening? return in R
+1 ;get measurements AUDC, AUDT, CRFTT
+2 NEW R,X,M,P,E
+3 SET R=""
+4 SET P=$PIECE(^AMHREC(V,0),U,8)
+5 SET X=0
FOR
SET X=$ORDER(^AMHRMSR("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET M=$$VAL^XBDIQ1(9002011.12,X,.01)
+7 IF M="AUDC"!(M="AUDT")!(M="CRFT")
SET R=$$BHRT^APCLAL1(V,M,$PIECE(^AMHRMSR(X,0),U,4),P,$$VALI^XBDIQ1(9002011.12,X,1204))
End DoDot:1
+8 IF R]""
QUIT R
+9 ;get exam
+10 SET E=$PIECE($GET(^AMHREC(V,14)),U,3)
+11 IF E]""
SET R=$$BHRT^APCLAL1(V,"ALCOHOL SCREENING EXAM",$$VAL^XBDIQ1(9002011,V,1403),P,$PIECE($GET(^AMHREC(V,14)),U,4),$PIECE($GET(^AMHREC(V,16)),U,1))
+12 IF R]""
QUIT R
+13 ;get health factor
+14 SET X=0
FOR
SET X=$ORDER(^AMHRHF("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+15 SET M=$$VALI^XBDIQ1(9002011.08,X,.01)
+16 IF $PIECE(^AUTTHF($PIECE(^AUTTHF(M,0),U,3),0),U)="ALCOHOL/DRUG"
SET R=$$BHRT^APCLAL1(V,$$VAL^XBDIQ1(9002011.08,X,.01),"",P,$$VALI^XBDIQ1(9002011.08,X,.05),$PIECE($GET(^AMHRHF(V,811)),U,1))
End DoDot:1
+17 IF R]""
QUIT R
+18 ;get pov
+19 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+20 SET M=$$VAL^XBDIQ1(9002011.01,X,.01)
+21 IF M="29.1"!(M="V79.1")
SET R=$$BHRT^APCLAL1(V,M,"",P,$$VALI^XBDIQ1(9002011.01,X,1204))
End DoDot:1
+22 IF R]""
QUIT R
+23 ;get education
+24 SET X=0
FOR
SET X=$ORDER(^AMHREDU("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+25 SET M=$$VAL^XBDIQ1(9002011.05,X,.01)
+26 IF M="CD-SCR"!(M="AOD-SCR")
SET R=$$BHRT^APCLAL1(V,M,"",P,$$VALI^XBDIQ1(9002011.05,X,.04),$PIECE($GET(^AMHREDU(V,11)),U,1))
End DoDot:1
+27 IF R]""
QUIT R
+28 ;get CPTs
+29 SET X=0
FOR
SET X=$ORDER(^AMHRPROC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+30 SET M=$$VALI^XBDIQ1(9002011.04,X,.01)
+31 IF '$$ICD^ATXAPI(M,$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),1)
QUIT
+32 SET R=$$BHRT^APCLAL1(V,"CPT: "_$$VAL^XBDIQ1(9002011.04,X,.01),"",P,"")
End DoDot:1
+33 IF R]""
QUIT R
+34 QUIT R
+35 ;
PCCSCR(V) ;EP - is there a screening? return in R
+1 ;get measurements AUDC, AUDT, CRFTT
+2 NEW R,X,M,P,E
+3 SET R=""
+4 SET P=$PIECE(^AUPNVSIT(V,0),U,5)
+5 SET D=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 ;entered in error
IF $PIECE($GET(^AUPNVMSR(X,2)),U,1)
QUIT
+8 SET M=$$VAL^XBDIQ1(9000010.01,X,.01)
+9 IF M="AUDC"!(M="AUDT")!(M="CRFT")
Begin DoDot:2
+10 SET T=D_U_M_U_$$VAL^XBDIQ1(9000010.01,X,.04)_U_V_U_9000010.01_U_X
+11 SET R=$$PCCV^APCLAL1(T,P)
End DoDot:2
End DoDot:1
+12 IF R]""
QUIT R
+13 ;get exam
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVXAM("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+15 SET M=$$VAL^XBDIQ1(9000010.13,X,.01)
+16 IF M="ALCOHOL SCREENING"
Begin DoDot:2
+17 SET T=D_U_M_U_$$VAL^XBDIQ1(9000010.13,X,.04)_U_V_U_9000010.13_U_X
+18 SET R=$$PCCV^APCLAL1(T,P)
End DoDot:2
End DoDot:1
+19 IF R]""
QUIT R
+20 ;get health factor
+21 SET X=0
FOR
SET X=$ORDER(^AUPNVHF("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+22 SET M=$$VALI^XBDIQ1(9000010.23,X,.01)
+23 IF $PIECE(^AUTTHF($PIECE(^AUTTHF(M,0),U,3),0),U)="ALCOHOL/DRUG"
Begin DoDot:2
+24 SET T=D_U_$$VAL^XBDIQ1(9000010.23,X,.01)_U_U_V_U_9000010.23_U_X
+25 SET R=$$PCCV^APCLAL1(T,P)
End DoDot:2
End DoDot:1
+26 IF R]""
QUIT R
+27 ;get pov
+28 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+29 SET M=$$VAL^XBDIQ1(9000010.07,X,.01)
+30 ;NO ICD10 CODES PER FRAN
IF M="V79.1"
Begin DoDot:2
+31 SET T=D_U_M_U_U_V_U_9000010.07_U_X
+32 SET R=$$PCCV^APCLAL1(T,P)
End DoDot:2
End DoDot:1
+33 IF R]""
QUIT R
+34 ;get education
+35 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+36 SET M=$$VAL^XBDIQ1(9000010.16,X,.01)
+37 IF M="CD-SCR"!(M="AOD-SCR")
Begin DoDot:2
+38 SET T=D_U_M_U_U_V_U_9000010.16_U_X
+39 SET R=$$PCCV^APCLAL1(T,P)
End DoDot:2
End DoDot:1
+40 IF R]""
QUIT R
+41 ;get CPTs
+42 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+43 SET M=$$VALI^XBDIQ1(9000010.18,X,.01)
+44 IF '$$ICD^ATXAPI(M,$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),1)
QUIT
+45 SET T=D_U_"CPT: "_$$VAL^XBDIQ1(9000010.18,X,.01)_U_U_V_U_9000010.18_U_X
+46 SET R=$$PCCV^APCLAL1(T,P)
End DoDot:1
+47 IF R]""
QUIT R
+48 QUIT R
+49 ;
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 ;----------
