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

AMHRDV2.m

Go to the documentation of this file. 
  1. AMHRDV2 ; IHS/CMI/LAB - list refusals ;
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
  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 the Behavioral Health"
  1.  W !?10,"   and PCC clinical databases for evidence of screening/refusal"
  1.  W !
  1.  D DBHUSR^AMHUTIL
  1.  D XIT
  1.  S AMHREXC=$O(^AUTTEXAM("C",34,0))
  1.  I 'AMHREXC W !!,"Exam code 34 is missing from the EXAM table.  Cannot run report.",! H 3 D XIT Q
  1.  ;
  1. DATES K AMHRED,AMHRBD
  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 AMHRBD=Y
  1.  K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date for Screening"
  1.  D ^DIR Q:Y<1  S AMHRED=Y
  1.  ;
  1.  I AMHRED<AMHRBD 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 AMHRTALL
  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)  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 AMHRTALL=Y
  1.  S A=Y,C="" F I=1:1 S C=$P(A,",",I) Q:C=""  S AMHRTALL(C)=""
  1. EXCL ;
  1.  S AMHREXPC=""
  1.  W !!,"Would you like to include IPV/DV Screenings documented in the PCC clinical"
  1.  S DIR(0)="Y",DIR("A")="database",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G DATES
  1.  S AMHREXPC=Y
  1. LIST ;
  1.  S AMHRLIST=""
  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 AMHRLIST=Y
  1.  I 'AMHRLIST G DEMO
  1. LIST1 ;
  1.  S AMHRSORT=""
  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 AMHRSORT=Y
  1. DEMO ;
  1.  D DEMOCHK^AMHUTIL1(.AMHDEMO)
  1.  I AMHDEMO=-1 G LIST
  1. ZIS ;
  1.  S XBRP="PRINT^AMHRDV2P",XBRC="PROC^AMHRDV2",XBRX="XIT^AMHRDV2",XBNS="AMHR"
  1.  D ^XBDBQUE
  1.  D XIT
  1.  Q
  1. XIT ;
  1.  D EN^XBVK("AMHR")
  1.  D ^XBFMK
  1.  Q
  1. PROC ;
  1.  S AMHRCNT=0
  1.  S AMHRH=$H,AMHRJ=$J
  1.  K ^XTMP("AMHRDV2",AMHRJ,AMHRH)
  1.  D XTMP^AMHUTIL("AMHRDV2","IPV SCREENING REPORT")
  1.  ;now go through BH
  1.  S AMHRSD=$$FMADD^XLFDT(AMHRBD,-1),AMHRSD=AMHRSD_".9999"
  1.  F  S AMHRSD=$O(^AMHREC("B",AMHRSD)) Q:AMHRSD'=+AMHRSD!($P(AMHRSD,".")>AMHRED)  D
  1.  .S AMHRBIEN=0 F  S AMHRBIEN=$O(^AMHREC("B",AMHRSD,AMHRBIEN)) Q:AMHRBIEN'=+AMHRBIEN  D
  1.  ..S AMHRDATE=$P(AMHRSD,".")
  1.  ..Q:'$D(^AMHREC(AMHRBIEN,0))
  1.  ..Q:$P($G(^AMHREC(AMHRBIEN,14)),U)=""
  1.  ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHRBIEN)
  1.  ..Q:AMHRDATE>AMHRED
  1.  ..Q:AMHRDATE<AMHRBD
  1.  ..S DFN=$P(^AMHREC(AMHRBIEN,0),U,8)
  1.  ..Q:DFN=""
  1.  ..Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))
  1.  ..Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
  1.  ..;I $D(^XTMP("AMHRDV2",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)) Q
  1.  ..S AMHRCNT=AMHRCNT+1
  1.  ..S ^XTMP("AMHRDV2",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)=""
  1.  ..S AMHRRES=$$VAL^XBDIQ1(9002011,AMHRBIEN,1401) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING" S:AMHRRES["NEGATIVE" AMHRRES="NEGATIVE"
  1.  ..S ^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT)="BH"_U_$$BHPPNAME(AMHRBIEN)_U_AMHRRES_U_$$VAL^XBDIQ1(9002011,AMHRBIEN,1501)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHRBIEN
  1.  ..S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,9)=$$VAL^XBDIQ1(9002011,AMHRBIEN,.25)
  1.  ..S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,15)=AMHRBIEN
  1.  ..S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,16)=$S($P($G(^AMHREC(AMHRBIEN,14)),U,2):$$VAL^XBDIQ1(9002011,AMHRBIEN,1402),1:"UNKNOWN")
  1.  ..S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
  1.  ..S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,18)=$$VAL^XBDIQ1(9002011.55,DFN,.02)
  1.  ..S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,19)=$$VAL^XBDIQ1(9002011.55,DFN,.03)
  1.  ..S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,20)=$$VAL^XBDIQ1(9002011.55,DFN,.04)
  1.  ..S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,21)=DFN
  1.  ;go through exam IPV, then through AUPNPREF for refusals
  1.  Q:'AMHREXPC
  1.  S AMHREIEN=0 F  S AMHREIEN=$O(^AUPNVXAM("B",AMHREXC,AMHREIEN)) Q:AMHREIEN'=+AMHREIEN  D
  1.  .Q:'$D(^AUPNVXAM(AMHREIEN,0))
  1.  .S DFN=$P(^AUPNVXAM(AMHREIEN,0),U,2)
  1.  .Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
  1.  .Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))
  1.  .S AMHRVIEN=$P(^AUPNVXAM(AMHREIEN,0),U,3)
  1.  .Q:'AMHRVIEN
  1.  .Q:'$$ALLOWPCC^AMHUTIL(DUZ,AMHRVIEN)
  1.  .S AMHRDATE=$P($P($G(^AUPNVSIT(AMHRVIEN,0)),U),".")
  1.  .Q:AMHRDATE=""
  1.  .Q:AMHRDATE>AMHRED
  1.  .Q:AMHRDATE<AMHRBD
  1.  .I $D(^XTMP("AMHRDV2",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)) Q
  1.  .S AMHRCNT=AMHRCNT+1
  1.  .S ^XTMP("AMHRDV2",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)=""
  1.  .S AMHRRES=$$VAL^XBDIQ1(9000010.13,AMHREIEN,.04) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING" S:AMHRRES["NEGATIVE" AMHRRES="NEGATIVE"
  1.  .S ^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT)="EX"_U_$$PPV(AMHRVIEN)_U_AMHRRES_U_$$VAL^XBDIQ1(9000010.13,AMHREIEN,81101)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHREIEN
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,9)=$$VAL^XBDIQ1(9000010,AMHRVIEN,.08)
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,15)=AMHRVIEN
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,16)=$$SPRV(AMHREIEN)
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,18)=$$VAL^XBDIQ1(9002011.55,DFN,.02)
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,19)=$$VAL^XBDIQ1(9002011.55,DFN,.03)
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,20)=$$VAL^XBDIQ1(9002011.55,DFN,.04)
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,21)=DFN
  1.  ;now go through refusals in pcc
  1.  S AMHRRIEN=0 F  S AMHRRIEN=$O(^AUPNPREF(AMHRRIEN)) Q:AMHRRIEN'=+AMHRRIEN  D
  1.  .Q:'$D(^AUPNPREF(AMHRRIEN,0))
  1.  .Q:$P(^AUPNPREF(AMHRRIEN,0),U,5)'=9999999.15
  1.  .Q:$P(^AUPNPREF(AMHRRIEN,0),U,6)'=AMHREXC
  1.  .S AMHRDATE=$P(^AUPNPREF(AMHRRIEN,0),U,3)
  1.  .Q:AMHRDATE=""
  1.  .Q:AMHRDATE>AMHRED
  1.  .Q:AMHRDATE<AMHRBD
  1.  .S DFN=$P(^AUPNPREF(AMHRRIEN,0),U,2)
  1.  .Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
  1.  .Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))
  1.  .I $D(^XTMP("AMHRDV2",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)) Q
  1.  .S AMHRCNT=AMHRCNT+1
  1.  .S ^XTMP("AMHRDV2",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)=""
  1.  .S AMHRRES=$$VAL^XBDIQ1(9000022,AMHRRIEN,.07) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING" S:AMHRRES["NEGATIVE" AMHRRES="NEGATIVE"
  1.  .S ^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT)="REF"_U_"UNKNOWN"_U_AMHRRES_U_$$VAL^XBDIQ1(9000022,AMHRRIEN,1101)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHRRIEN_U
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,15)=AMHRVIEN
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,16)=$$PRVREF(AMHRRIEN)
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,18)=$$VAL^XBDIQ1(9002011.55,DFN,.02)
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,19)=$$VAL^XBDIQ1(9002011.55,DFN,.03)
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,20)=$$VAL^XBDIQ1(9002011.55,DFN,.04)
  1.  .S $P(^XTMP("AMHRDV2",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,21)=DFN
  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) ;
  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.  ;----------