Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCLAL2

APCLAL2.m

Go to the documentation of this file. 
  1. APCLAL2 ; IHS/CMI/LAB - list refusals ; 
  1.  ;;2.0;IHS PCC SUITE;**2,4,11**;MAY 14, 2009;Build 58
  1.  ;
  1.  ;
  1. INFORM ;
  1.  W !,$$CTR($$USR)
  1.  W !,$$LOC()
  1.  W !!,$$CTR("TALLY AND LISTING OF ALL VISITS W/ALCOHOL SCREENING",80)
  1.  W !!,"This report will tally and optionally list all visits on which ALCOHOL"
  1.  W !,"screening or a refusal was documented in the time frame specified by the"
  1.  W !,"user.  Alcohol Screening is defined as any of the following documented:"
  1.  W !?5,"- Alcohol Screening Exam (Exam code 35)"
  1.  W !?5,"- Measurements: AUDC, AUDT, CRFT"
  1.  W !?5,"- Health Factor with Alcohol/Drug Category (CAGE)"
  1.  W !?5,"- Diagnoses V79.1 (there are no ICD10 codes), 29.1 (Behavioral Hlth Code)"
  1.  W !?5,"- Education Topics: AOD-SCR, CD-SCR"
  1.  W !?5,"- CPT Codes: 99408, 99409, G0396, G0397, H0049"
  1.  W !?5,"- refusal of exam code 35"
  1.  W !,"This report will tally the visits by age, gender, screening result,"
  1.  W !,"provider (either exam provider, if available, or primary provider on the "
  1.  W !,"visit), clinic, date of screening, designated PCP, MH Provider, SS Provider"
  1.  W !,"and A/SA Provider."
  1.  W !,"  Notes:  "
  1.  W !?10,"- this report will optionally, look at both PCC and the Behavioral"
  1.  W !?10,"   Health clinics for evidence of screening/refusal"
  1.  W !?10,"- this is a tally of visits with a screening done, if a patient had"
  1.  W !?10,"   multiple screenings during the time period, all will be counted"
  1.  W !
  1.  D PAUSE^APCLVL01
  1.  D XIT
  1.  S APCREXC=$O(^AUTTEXAM("C",35,0))
  1.  I 'APCREXC W !!,"Exam code 35 is missing from the EXAM table.  Cannot run report.",! H 3 D XIT Q
  1.  ;
  1. DATES K APCRED,APCRBD
  1.  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.",!
  1.  K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date for Screening"
  1.  D ^DIR Q:Y<1  S APCRBD=Y
  1.  K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date for Screening"
  1.  D ^DIR Q:Y<1  S APCRED=Y
  1.  ;
  1.  I APCRED<APCRBD D  G DATES
  1.  . W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
  1.  ;
  1. TALLY ;which items to tally
  1.  K APCRTALL
  1.  W !!,"Please select which items you wish to tally on this report:",!
  1.  W !?3,"0)  Do not include any Tallies",?40,"6)  Date of Screening"
  1.  W !?3,"1)  Type/Result of Screening",?40,"7)  Primary Provider on Visit"
  1.  W !?3,"2)  Gender",?40,"8)  Designated MH Provider"
  1.  W !?3,"3)  Age of Patient",?40,"9)  Designated SS Provider"
  1.  W !?3,"4)  Provider who Screened",?40,"10) Designated ASA/CD Provider"
  1.  W !?3,"5)  Clinic",?40,"11) Designated Primary Care Provider"
  1.  K DIR S DIR(0)="L^0:11",DIR("A")="Which items should be tallied",DIR("B")="" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G DATES
  1.  I Y="" G DATES
  1.  S APCRTALL=Y
  1.  S A=Y,C="" F I=1:1 S C=$P(A,",",I) Q:C=""  S APCRTALL(C)=""
  1. EXCL ;
  1.  S APCLEXBH=""
  1.  W !!,"Would you like to include screenings recorded in the Behavioral Clinics"
  1.  W !,"Mental Health (14); DEPRESSION and Substance Abuse (43), Medical Social"
  1.  S DIR(0)="Y",DIR("A")="Services, Behavioral Health (C4) and Telebehavioral Health (C9): ",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G DATES
  1.  S APCLEXBH=Y
  1.  S APCREXPC=1
  1. LIST ;
  1.  S APCRLIST=""
  1.  W !
  1.  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
  1.  I $D(DIRUT) G DATES
  1.  S APCRLIST=Y
  1.  I 'APCRLIST G ZIS
  1. LIST1 ;
  1.  S APCRSORT=""
  1.  W !
  1.  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"
  1.  S DIR("A")="How would you like the list to be sorted",DIR("B")="H"
  1.  KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G LIST
  1.  S APCRSORT=Y
  1. ZIS ;
  1.  S XBRP="PRINT^APCLAL2P",XBRC="PROC^APCLAL2",XBRX="XIT^APCLAL2",XBNS="APC"
  1.  D ^XBDBQUE
  1.  D XIT
  1.  Q
  1. XIT ;
  1.  D EN^XBVK("APC")
  1.  D ^XBFMK
  1.  Q
  1. PROC ;
  1.  S APCRCNT=0
  1.  S APCRH=$H,APCRJ=$J
  1.  K ^XTMP("APCLAL2",APCRJ,APCRH)
  1.  D XTMP^AMHUTIL("APCLAL2","ALCOHOL SCREENING REPORT")
  1.  ;now go through BH
  1.  S APCRSD=$$FMADD^XLFDT(APCRBD,-1),APCRSD=APCRSD_".9999"
  1.  I 'APCLEXBH G PCC
  1.  F  S APCRSD=$O(^AMHREC("B",APCRSD)) Q:APCRSD'=+APCRSD!($P(APCRSD,".")>APCRED)  D
  1.  .S APCRBIEN=0 F  S APCRBIEN=$O(^AMHREC("B",APCRSD,APCRBIEN)) Q:APCRBIEN'=+APCRBIEN  D
  1.  ..S APCRDATE=$P(APCRSD,".")
  1.  ..Q:'$D(^AMHREC(APCRBIEN,0))
  1.  ..;Q:'$$ALLOWVI^AMHUTIL(DUZ,APCRBIEN)
  1.  ..Q:APCRDATE>APCRED
  1.  ..Q:APCRDATE<APCRBD
  1.  ..S DFN=$P(^AMHREC(APCRBIEN,0),U,8)
  1.  ..Q:DFN=""
  1.  ..;Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
  1.  ..S APCSCR=$$BHSCR(APCRBIEN)
  1.  ..Q:APCSCR=""
  1.  ..S APCRCNT=APCRCNT+1
  1.  ..S ^XTMP("APCLAL2",APCRJ,APCRH,"PTS",DFN,APCRDATE)=""
  1.  ..S ^XTMP("APCLAL2",APCRJ,APCRH,"VSTS",APCRCNT)=APCSCR
  1. PCC ;
  1.  ;Q:'APCREXPC
  1.  S APCRSD=$$FMADD^XLFDT(APCRBD,-1),APCRSD=APCRSD_".9999"
  1.  F  S APCRSD=$O(^AUPNVSIT("B",APCRSD)) Q:APCRSD'=+APCRSD!($P(APCRSD,".")>APCRED)  D
  1.  .S APCRBIEN=0 F  S APCRBIEN=$O(^AUPNVSIT("B",APCRSD,APCRBIEN)) Q:APCRBIEN'=+APCRBIEN  D
  1.  ..S APCRDATE=$P(APCRSD,".")
  1.  ..Q:'$D(^AUPNVSIT(APCRBIEN,0))
  1.  ..I APCLEXBH Q:$D(^AMHREC("AVISIT",APCRBIEN))  ;visit is in BH
  1.  ..;Q:'$$ALLOWPCC^AMHUTIL(DUZ,APCRBIEN)
  1.  ..Q:APCRDATE>APCRED
  1.  ..Q:APCRDATE<APCRBD
  1.  ..S DFN=$P(^AUPNVSIT(APCRBIEN,0),U,5)
  1.  ..Q:DFN=""
  1.  ..I 'APCLEXBH S C=$$CLINIC^APCLV(APCRBIEN,"C") I C=14!(C=43)!(C=48)!(C="C4")!(C="C9") Q
  1.  ..;Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
  1.  ..S APCSCR=$$PCCSCR(APCRBIEN)
  1.  ..Q:APCSCR=""
  1.  ..S APCRCNT=APCRCNT+1
  1.  ..S ^XTMP("APCLAL2",APCRJ,APCRH,"PTS",DFN,APCRDATE)=""
  1.  ..S ^XTMP("APCLAL2",APCRJ,APCRH,"VSTS",APCRCNT)=APCSCR
  1.  ;now go through refusals in pcc
  1.  S APCRRIEN=0 F  S APCRRIEN=$O(^AUPNPREF(APCRRIEN)) Q:APCRRIEN'=+APCRRIEN  D
  1.  .Q:'$D(^AUPNPREF(APCRRIEN,0))
  1.  .Q:$P(^AUPNPREF(APCRRIEN,0),U,5)'=9999999.15
  1.  .Q:$P(^AUPNPREF(APCRRIEN,0),U,6)'=APCREXC
  1.  .S APCRDATE=$P(^AUPNPREF(APCRRIEN,0),U,3)
  1.  .Q:APCRDATE=""
  1.  .Q:APCRDATE>APCRED
  1.  .Q:APCRDATE<APCRBD
  1.  .S DFN=$P(^AUPNPREF(APCRRIEN,0),U,2)
  1.  .I $D(^XTMP("APCLAL2",APCRJ,APCRH,"PTS",DFN,APCRDATE)) Q
  1.  .S APCRCNT=APCRCNT+1
  1.  .S ^XTMP("APCLAL2",APCRJ,APCRH,"PTS",DFN,APCRDATE)=""
  1.  .S T=APCRDATE
  1.  .S $P(T,U,2)="REFUSED;"_$$VAL^XBDIQ1(9000022,APCRRIEN,.07)
  1.  .S $P(T,U,3)=$P(^DPT(DFN,0),U,2)
  1.  .S $P(T,U,4)=$$AGE^AUPNPAT(DFN,APCRDATE)
  1.  .S $P(T,U,5)=$$VAL^XBDIQ1(9000022,APCRRIEN,1204) I $P(T,U,5)="" S $P(T,U,5)="UNKNOWN"
  1.  .S $P(T,U,6)="UNKNOWN"
  1.  .S $P(T,U,7)="UNKNOWN"
  1.  .S $P(T,U,8)=$$VAL^XBDIQ1(9002011.55,DFN,.02)
  1.  .S $P(T,U,9)=$$VAL^XBDIQ1(9002011.55,DFN,.03)
  1.  .S $P(T,U,10)=$$VAL^XBDIQ1(9002011.55,DFN,.04)
  1.  .S $P(T,U,11)=$$VAL^XBDIQ1(9000001,DFN,.14)
  1.  .S $P(T,U,15)=DFN
  1.  .S $P(T,U,20)="PCC"
  1.  .S ^XTMP("APCLAL2",APCRJ,APCRH,"VSTS",APCRCNT)=T
  1.  Q
  1.  ;
  1. BHSCR(V) ;EP - is there a screening?  return in R
  1.  ;get measurements AUDC, AUDT, CRFTT
  1.  NEW R,X,M,P,E
  1.  S R=""
  1.  S P=$P(^AMHREC(V,0),U,8)
  1.  S X=0 F  S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X  D
  1.  .S M=$$VAL^XBDIQ1(9002011.12,X,.01)
  1.  .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))
  1.  I R]"" Q R
  1.  ;get exam
  1.  S E=$P($G(^AMHREC(V,14)),U,3)
  1.  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))
  1.  I R]"" Q R
  1.  ;get health factor
  1.  S X=0 F  S X=$O(^AMHRHF("AD",V,X)) Q:X'=+X  D
  1.  .S M=$$VALI^XBDIQ1(9002011.08,X,.01)
  1.  .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))
  1.  I R]"" Q R
  1.  ;get pov
  1.  S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X  D
  1.  .S M=$$VAL^XBDIQ1(9002011.01,X,.01)
  1.  .I M="29.1"!(M="V79.1") S R=$$BHRT^APCLAL1(V,M,"",P,$$VALI^XBDIQ1(9002011.01,X,1204))
  1.  I R]"" Q R
  1.  ;get education
  1.  S X=0 F  S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X  D
  1.  .S M=$$VAL^XBDIQ1(9002011.05,X,.01)
  1.  .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))
  1.  I R]"" Q R
  1.  ;get CPTs
  1.  S X=0 F  S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X  D
  1.  .S M=$$VALI^XBDIQ1(9002011.04,X,.01)
  1.  .Q:'$$ICD^ATXAPI(M,$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),1)
  1.  .S R=$$BHRT^APCLAL1(V,"CPT: "_$$VAL^XBDIQ1(9002011.04,X,.01),"",P,"")
  1.  I R]"" Q R
  1.  Q R
  1.  ;
  1. PCCSCR(V) ;EP - is there a screening?  return in R
  1.  ;get measurements AUDC, AUDT, CRFTT
  1.  NEW R,X,M,P,E
  1.  S R=""
  1.  S P=$P(^AUPNVSIT(V,0),U,5)
  1.  S D=$P($P(^AUPNVSIT(V,0),U),".")
  1.  S X=0 F  S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X  D
  1.  .Q:$P($G(^AUPNVMSR(X,2)),U,1)  ;entered in error
  1.  .S M=$$VAL^XBDIQ1(9000010.01,X,.01)
  1.  .I M="AUDC"!(M="AUDT")!(M="CRFT") D
  1.  ..S T=D_U_M_U_$$VAL^XBDIQ1(9000010.01,X,.04)_U_V_U_9000010.01_U_X
  1.  ..S R=$$PCCV^APCLAL1(T,P)
  1.  I R]"" Q R
  1.  ;get exam
  1.  S X=0 F  S X=$O(^AUPNVXAM("AD",V,X)) Q:X'=+X  D
  1.  .S M=$$VAL^XBDIQ1(9000010.13,X,.01)
  1.  .I M="ALCOHOL SCREENING" D
  1.  ..S T=D_U_M_U_$$VAL^XBDIQ1(9000010.13,X,.04)_U_V_U_9000010.13_U_X
  1.  ..S R=$$PCCV^APCLAL1(T,P)
  1.  I R]"" Q R
  1.  ;get health factor
  1.  S X=0 F  S X=$O(^AUPNVHF("AD",V,X)) Q:X'=+X  D
  1.  .S M=$$VALI^XBDIQ1(9000010.23,X,.01)
  1.  .I $P(^AUTTHF($P(^AUTTHF(M,0),U,3),0),U)="ALCOHOL/DRUG" D
  1.  ..S T=D_U_$$VAL^XBDIQ1(9000010.23,X,.01)_U_U_V_U_9000010.23_U_X
  1.  ..S R=$$PCCV^APCLAL1(T,P)
  1.  I R]"" Q R
  1.  ;get pov
  1.  S X=0 F  S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X  D
  1.  .S M=$$VAL^XBDIQ1(9000010.07,X,.01)
  1.  .I M="V79.1" D    ;NO ICD10 CODES PER FRAN
  1.  ..S T=D_U_M_U_U_V_U_9000010.07_U_X
  1.  ..S R=$$PCCV^APCLAL1(T,P)
  1.  I R]"" Q R
  1.  ;get education
  1.  S X=0 F  S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X  D
  1.  .S M=$$VAL^XBDIQ1(9000010.16,X,.01)
  1.  .I M="CD-SCR"!(M="AOD-SCR") D
  1.  ..S T=D_U_M_U_U_V_U_9000010.16_U_X
  1.  ..S R=$$PCCV^APCLAL1(T,P)
  1.  I R]"" Q R
  1.  ;get CPTs
  1.  S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X  D
  1.  .S M=$$VALI^XBDIQ1(9000010.18,X,.01)
  1.  .Q:'$$ICD^ATXAPI(M,$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),1)
  1.  .S T=D_U_"CPT: "_$$VAL^XBDIQ1(9000010.18,X,.01)_U_U_V_U_9000010.18_U_X
  1.  .S R=$$PCCV^APCLAL1(T,P)
  1.  I R]"" Q R
  1.  Q R
  1.  ;
  1. BHPPNAME(R) ;EP primary provider internal # from 200
  1.  NEW %,%1
  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)
  1.  I %1]"" Q %1
  1.  Q "UNKNOWN"
  1. SPRV(E) ;
  1.  I $P($G(^AUPNVXAM(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.13,E,1204)
  1.  Q "UNKNOWN"
  1. PRVREF(R) ;
  1.  I $P($G(^AUPNPREF(R,12)),U,4)]"" Q $$VAL^XBDIQ1(9000022,R,1204)
  1.  Q "UNKNOWN"
  1. PPV(V) ;
  1.  NEW %
  1.  S %=$$PRIMPROV^APCLV(V)
  1.  I %]"" Q %
  1.  Q "UNKNOWN"
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:IO'=IO(0)
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  NEW DIR
  1.  K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  W !
  1.  S DIR("A")="End of Report.  Press Enter",DIR(0)="E" D ^DIR
  1.  Q
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------