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

APCLDV2.m

Go to the documentation of this file. 
  1. APCLDV2 ; IHS/CMI/LAB - list refusals ;
  1.  ;;2.0;IHS PCC SUITE;**8**;MAY 14, 2009;Build 2
  1.  ;
  1.  ;
  1. INFORM ;
  1.  W !,$$CTR($$USR)
  1.  W !,$$LOC()
  1.  W !!,$$CTR("TALLY AND LISTING OF ALL VISITS W/IPV SCREENING",80)
  1.  W !!,"This report will tally and optionally list all visits on which "
  1.  W !,"IPV screening (Exam code 34) or a refusal was documented in the"
  1.  W !,"time frame specified by the user."
  1.  W !,"This report will tally the visits by age, gender, result, provider (either"
  1.  W !,"exam provider, if available, or primary provider on the visit), and date of"
  1.  W !,"screening/refusal."
  1.  W !,"  Note:  "
  1.  W !?10,"- this report will optionally, look at both PCC and the Behavioral"
  1.  W !?10,"   Health databases for evidence of screening/refusal"
  1.  W !
  1.  D XIT
  1.  S APCLEXC=$O(^AUTTEXAM("C",34,0))
  1.  I 'APCLEXC W !!,"Exam code 34 is missing from the EXAM table.  Cannot run report.",! H 3 D XIT Q
  1.  ;
  1. DATES K APCLED,APCLBD
  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 APCLBD=Y
  1.  K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date for Screening"
  1.  D ^DIR Q:Y<1  S APCLED=Y
  1.  ;
  1.  I APCLED<APCLBD 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 APCLTALL
  1.  W !!,"Please select which items you wish to tally on this report:",!
  1.  W !?3,"0)  Do not include any Tallies",?40,"5)  Primary Provider of Visit"
  1.  W !?3,"1)  Result of Screening",?40,"6)  Designated Primary Care Provider"
  1.  W !?3,"2)  Gender",?40,"7)  Clinic"
  1.  W !?3,"3)  Age of Patient",?40,"8)  Date of Screening"
  1.  W !?3,"4)  Provider who Screened"
  1.  K DIR S DIR(0)="L^0:8",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 APCLTALL=Y
  1.  S A=Y,C="" F I=1:1 S C=$P(A,",",I) Q:C=""  S APCLTALL(C)=""
  1. EXCL ;
  1.  S APCLEXBH=""
  1.  W !!,"Would you like to include screenings done in the behavioral health clinics: "
  1.  W !,"Mental Health (14); Alcohol and Substance Abuse (43); Medical"
  1.  W !,"Social Services (48); Behavioral Health (C4) "
  1.  S DIR(0)="Y",DIR("A")="and Telebehavioral Health (C9)",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G DATES
  1.  S APCLEXBH=Y
  1. FAC ;
  1.  K APCLQ
  1.  S APCLLOCT=""
  1.  S DIR(0)="S^A:ALL Locations/Facilities;S:One SERVICE UNIT'S Locations/Facilities;O:ONE Location/Facility",DIR("A")="Include Visits to Which Location/Facilities",DIR("B")="A"
  1.  S DIR("A")="Include screenings done at which facilities",DIR("B")="O" K DA D ^DIR K DIR,DA
  1.  G:$D(DIRUT) EXCL
  1.  S APCLLOCT=Y
  1.  I APCLLOCT="A" G COMM
  1.  D @APCLLOCT^APCLDV1
  1.  G:$D(APCLQ) FAC
  1. COMM ;
  1.  K APCLQ
  1.  S APCLCOMT=""
  1.  W !!,"You can just include patients living in certain communities",!,"or include all patients regardless of where they live."
  1.  S DIR(0)="S^A:ALL Patient Communitiess;S:Selected Set (taxonomy) of Communities;O:ONE Community",DIR("A")="Include Visits to Which Location/Facilities",DIR("B")="A"
  1.  S DIR("A")="Include screenings done at which facilities",DIR("B")="O" K DA D ^DIR K DIR,DA
  1.  G:$D(DIRUT) FAC
  1.  S APCLCOMT=Y
  1.  I APCLCOMT="A" G LIST
  1.  D @(APCLCOMT_"C")^APCLDV1
  1.  G:$D(APCLQ) COMM
  1. LIST ;
  1.  S APCLLIST=""
  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 APCLLIST=Y
  1.  I 'APCLLIST G ZIS
  1. LIST1 ;
  1.  S APCLSORT=""
  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 APCLSORT=Y
  1. ZIS ;
  1. DEMO ;
  1.  D DEMOCHK^APCLUTL(.APCLDEMO)
  1.  I APCLDEMO=-1 G LIST
  1.  S XBRP="PRINT^APCLDV2P",XBRC="PROC^APCLDV2",XBRX="XIT^APCLDV2",XBNS="APCL"
  1.  D ^XBDBQUE
  1.  D XIT
  1.  Q
  1. XIT ;
  1.  D EN^XBVK("APCL")
  1.  D ^XBFMK
  1.  Q
  1. PROC ;
  1.  S APCLCNT=0
  1.  S APCLH=$H,APCLJ=$J
  1.  K ^XTMP("APCLDV2",APCLJ,APCLH)
  1.  D XTMP^APCLOSUT("APCLDV2","IPV SCREENING REPORT")
  1.  ;go through exam IPV, then through AUPNPREF for refusals
  1.  S APCLEIEN=0 F  S APCLEIEN=$O(^AUPNVXAM("B",APCLEXC,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN  D
  1.  .Q:'$D(^AUPNVXAM(APCLEIEN,0))
  1.  .S DFN=$P(^AUPNVXAM(APCLEIEN,0),U,2)
  1.  .Q:DFN=""
  1.  .Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
  1.  .I APCLCOMT="O",$$COMMRES^AUPNPAT(DFN,"I")'=APCLCOMT("ONE") Q  ;not in community
  1.  .I APCLCOMT="S" S X=$$COMMRES^AUPNPAT(DFN,"E") I '$D(APCLTAX(X)) Q  ;not in comm taxonomy
  1.  .S APCLVIEN=$P(^AUPNVXAM(APCLEIEN,0),U,3)
  1.  .Q:'APCLVIEN
  1.  .S APCLDATE=$P($P($G(^AUPNVSIT(APCLVIEN,0)),U),".")
  1.  .Q:APCLDATE=""
  1.  .Q:APCLDATE>APCLED
  1.  .Q:APCLDATE<APCLBD
  1.  .I APCLLOCT="O",$P(^AUPNVSIT(APCLVIEN,0),U,6)'=APCLLOCT("ONE") Q
  1.  .I APCLLOCT="S",$$VALI^XBDIQ1(9999999.06,$P(^AUPNVSIT(APCLVIEN,0),U,6),.05)'=APCLLOCT("SU") Q
  1.  .I 'APCLEXBH S C=$$CLINIC^APCLV(APCLVIEN,"C") I C=14!(C=43)!(C=48)!(C="C4")!(C="C9") Q
  1.  .S APCLCNT=APCLCNT+1
  1.  .S APCLRES=$$VAL^XBDIQ1(9000010.13,APCLEIEN,.04) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
  1.  .S ^XTMP("APCLDV2",APCLJ,APCLH,"VSTS",APCLCNT)="EX"_U_$$PPV(APCLVIEN)_U_APCLRES_U_$$VAL^XBDIQ1(9000010.13,APCLEIEN,81101)_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN_U_DFN
  1.  .S $P(^XTMP("APCLDV2",APCLJ,APCLH,"VSTS",APCLCNT),U,10)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
  1.  .S $P(^XTMP("APCLDV2",APCLJ,APCLH,"VSTS",APCLCNT),U,15)=APCLVIEN
  1.  .S $P(^XTMP("APCLDV2",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$SPRV(APCLEIEN)
  1.  .S $P(^XTMP("APCLDV2",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
  1.  .S ^XTMP("APCLDV2",APCLJ,APCLH,"PTS",DFN,APCLDATE)=APCLCNT
  1.  ;now go through refusals in pcc
  1.  S APCLRIEN=0 F  S APCLRIEN=$O(^AUPNPREF(APCLRIEN)) Q:APCLRIEN'=+APCLRIEN  D
  1.  .Q:'$D(^AUPNPREF(APCLRIEN,0))
  1.  .Q:$P(^AUPNPREF(APCLRIEN,0),U,5)'=9999999.15
  1.  .Q:$P(^AUPNPREF(APCLRIEN,0),U,6)'=APCLEXC
  1.  .S APCLDATE=$P(^AUPNPREF(APCLRIEN,0),U,3)
  1.  .Q:APCLDATE=""
  1.  .Q:APCLDATE>APCLED
  1.  .Q:APCLDATE<APCLBD
  1.  .S DFN=$P(^AUPNPREF(APCLRIEN,0),U,2)
  1.  .Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
  1.  .I APCLCOMT="O",$$COMMRES^AUPNPAT(DFN,"I")'=APCLCOMT("ONE") Q  ;not in community
  1.  .I APCLCOMT="S" S X=$$COMMRES^AUPNPAT(DFN,"E") I '$D(APCLTAX(X)) Q  ;not in comm taxonomy
  1.  .S APCLRES=$$VAL^XBDIQ1(9000022,APCLRIEN,.07) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
  1.  .S APCLCNT=APCLCNT+1
  1.  .S ^XTMP("APCLDV2",APCLJ,APCLH,"VSTS",APCLCNT)="REF"_U_"UNKNOWN"_U_APCLRES_U_$$VAL^XBDIQ1(9000022,APCLRIEN,1101)_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLRIEN_U_DFN_U
  1.  .S $P(^XTMP("APCLDV2",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$PRVREF(APCLRIEN)
  1.  .S $P(^XTMP("APCLDV2",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
  1.  .S ^XTMP("APCLDV2",APCLJ,APCLH,"PTS",DFN,APCLDATE)=APCLCNT
  1.  ;now go through BH
  1.  Q:'APCLEXBH  ;not if user doesn't want to
  1.  S APCLSD=$$FMADD^XLFDT(APCLBD,-1),APCLSD=APCLSD_".9999"
  1.  F  S APCLSD=$O(^AMHREC("B",APCLSD)) Q:APCLSD'=+APCLSD!($P(APCLSD,".")>APCLED)  D
  1.  .S APCLBIEN=0 F  S APCLBIEN=$O(^AMHREC("B",APCLSD,APCLBIEN)) Q:APCLBIEN'=+APCLBIEN  D
  1.  ..S APCLDATE=$P(APCLSD,".")
  1.  ..Q:'$D(^AMHREC(APCLBIEN,0))
  1.  ..Q:$P($G(^AMHREC(APCLBIEN,14)),U)=""
  1.  ..Q:APCLDATE>APCLED
  1.  ..Q:APCLDATE<APCLBD
  1.  ..I APCLLOCT="O",$P(^AMHREC(APCLBIEN,0),U,4)'=APCLLOCT("ONE") Q
  1.  ..I APCLLOCT="S",$$VALI^XBDIQ1(9999999.06,$P(^AMHREC(APCLBIEN,0),U,4),.05)'=APCLLOCT("SU") Q
  1.  ..S DFN=$P(^AMHREC(APCLBIEN,0),U,8) Q:'DFN
  1.  ..Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
  1.  ..I APCLCOMT="O",$$COMMRES^AUPNPAT(DFN,"I")'=APCLCOMT("ONE") Q  ;not in community
  1.  ..I APCLCOMT="S" S X=$$COMMRES^AUPNPAT(DFN,"E") I '$D(APCLTAX(X)) Q  ;not in comm taxonomy
  1.  ..I $D(^XTMP("APCLDV2",APCLJ,APCLH,"PTS",DFN,APCLDATE)) Q
  1.  ..S APCLCNT=APCLCNT+1
  1.  ..S APCLRES=$$VAL^XBDIQ1(9002011,APCLBIEN,1401) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
  1.  ..S ^XTMP("APCLDV2",APCLJ,APCLH,"VSTS",APCLCNT)="BH"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_$$VAL^XBDIQ1(9002011,APCLBIEN,1501)_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLBIEN_U_DFN
  1.  ..S $P(^XTMP("APCLDV2",APCLJ,APCLH,"VSTS",APCLCNT),U,10)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
  1.  ..S $P(^XTMP("APCLDV2",APCLJ,APCLH,"VSTS",APCLCNT),U,15)=APCLBIEN
  1.  ..S $P(^XTMP("APCLDV2",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$VAL^XBDIQ1(9002011,APCLBIEN,1402)
  1.  ..S $P(^XTMP("APCLDV2",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
  1.  ..S ^XTMP("APCLDE2",APCLJ,APCLH,"PTS",DFN,APCLSD)=APCLCNT
  1.  Q
  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) ;EP
  1.  ;get 1204 if it exists, otherwise take 1202
  1.  I $P($G(^AUPNVXAM(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.13,E,1204)
  1.  I $P($G(^AUPNVXAM(E,12)),U,2) Q $$VAL^XBDIQ1(9000010.13,E,1202)
  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.  ;----------