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

BWMDEX0.m

Go to the documentation of this file. 
  1. BWMDEX0 ;IHS/CIA/DKM - Export filters;25-Feb-2011 14:23;PLS
  1.  ;;2.0;WOMEN'S HEALTH;**9,11,12**;MAY 16, 1996
  1.  ;
  1.  ; Generic screen for multi-valued list.
  1.  ; BWVAL = Value to screen (or array of values)
  1.  ; Return= Nonzero if meets inclusion criteria.
  1. SCREEN(BWVAL) ;
  1.  Q:$D(BWFLT(BWFLT,"V"))<10 1
  1.  S:$L($G(BWVAL)) BWVAL(BWVAL)=""
  1.  S BWVAL=""
  1.  F  S BWVAL=$O(BWVAL(BWVAL)) Q:'$L(BWVAL)  Q:$D(BWFLT(BWFLT,"V",BWVAL))
  1.  Q $L(BWVAL)
  1.  ; Generic prompt logic for file selection.
  1.  ;
  1. PROMPT(BWPMT,BWFN,BWDFL,BWSET) ;
  1.  D SELECT^BWUTLP($S(BWFLT(BWFLT,"N"):"-",1:"")_BWPMT,BWFN,$NA(BWFLT(BWFLT,"V")),"",$G(BWDFL),.BWPOP,.BWSET,0)
  1.  Q
  1.  ; Generic display logic for multi-valued list.
  1. DISPLAY(BWLBL,BWFN,BWSET) ;
  1.  N BWLP,BWDLM,X
  1.  S BWLP=0,BWDLM=BWLBL_": "
  1.  F  S BWLP=$O(BWFLT(BWFLT,"V",BWLP)) Q:'BWLP  D
  1.  .I $G(BWSET) S X=$$LOW^XLFSTR($$EXTERNAL^DILFD(BWFN,BWSET,,BWLP))
  1.  .E  S X=$$GET1^DIQ(BWFN,BWLP,.01)
  1.  .W BWDLM
  1.  .W:$X+$L(X)'<$G(IOM,80) !?5
  1.  .W X
  1.  .S BWDLM="; "
  1.  I BWDLM="; " W ".",!
  1.  E  W "ALL "_BWLBL_".",!
  1.  Q
  1.  ; Screen by age range
  1. AGESCRN() ;
  1.  N BWAGE,BWDOD
  1.  S BWDOD=+$$DOD^AUPNPAT(BWDFN)
  1.  S BWAGE=+$$AGEAT^BWUTL1(BWDFN,$S(BWDOD:BWDOD,1:DT))
  1.  Q $S(BWAGE<$O(BWFLT(BWFLT,"V",0)):0,BWAGE>$O(BWFLT(BWFLT,"V",""),-1):0,1:1)
  1.  ; Prompt for age range
  1. AGEPMPT N BWAGE,BWHLP,BWLOW,BWHIGH
  1.  W "Enter age range for this export.",!
  1.  F BWAGE="1:99:18","1:99:64" D  Q:BWPOP
  1.  .S BWLOW=$P(BWAGE,":"),BWHIGH=$P(BWAGE,":",2),BWDEF=$P(BWAGE,":",3)
  1.  .S BWHLP="     Procedures for patients "_$S(BWLOW=18:"under",1:"over")_" this age will NOT be exported."
  1.  .S BWAGE=$$DIR^BWUTLP("N^"_BWLOW_":"_BWHIGH,"   Enter an age ("_BWLOW_"-"_BWHIGH_")",BWDEF,BWHLP,.BWPOP)
  1.  .S:'BWPOP BWFLT(BWFLT,"V",BWAGE)=""
  1.  Q
  1.  ; Display age range
  1. AGEDSPL W "ages ",$O(BWFLT(BWFLT,"V",0))," to ",$O(BWFLT(BWFLT,"V",""),-1),", inclusive.",!
  1.  Q
  1.  ; Screen by date range
  1. DATSCRN() ;
  1.  Q $S(BWDT<$O(BWFLT(BWFLT,"V",0)):0,BWDT>$O(BWFLT(BWFLT,"V",""),-1):0,1:1)
  1.  ; Prompt for date range
  1. DATPMPT N BWSTTDT,BWDT1,BWDT2
  1.  S BWSTTDT=$P(^BWSITE(DUZ(2),0),U,17)
  1.  D SHOWDLG^BWUTLP(9)
  1.  F  D ASKDATES^BWUTLP(.BWDT1,.BWDT2,.BWPOP,BWSTTDT) Q:BWPOP  Q:BWDT1'<BWSTTDT  D
  1.  .D SHOWDLG^BWUTLP(10)
  1.  S:'BWPOP BWFLT(BWFLT,"V",BWDT1)="",BWFLT(BWFLT,"V",BWDT2)=""
  1.  Q
  1.  ; Display date range
  1. DATDSPL W "procedures from ",$$FMTE^XLFDT($O(BWFLT(BWFLT,"V",0)))," to ",$$FMTE^XLFDT($O(BWFLT(BWFLT,"V",""),-1)),", inclusive.",!
  1.  Q
  1.  ; Screen CDC procedures
  1. CDCSCRN() ;
  1.  Q:BWPT=1!(BWPT=28) 1
  1.  I BWPT=25!(BWPT=26),$$PC^BWMDEX(2,32) Q 1
  1.  I BWPT=27,$$PC^BWMDEX(2,39),$$CBE^BWMDEX2=1 Q 1
  1.  Q 0
  1.  ; Evaluate Medicare Eligibility
  1. MCARE(BWDT,BWSC) ;
  1.  Q $$MELIG("^AUPNMCR",BWDT,.BWSC)
  1.  ; Evaluate Medicaid Elibibility
  1. MCAID(BWDT,BWSC) ;
  1.  Q $$MELIG("^AUPNMCD",BWDT,.BWSC)
  1.  ; Returns true if eligible for Medicare/Medicaid on date given.
  1. MELIG(BWGL,BWDT,BWSC) ;
  1.  N S,X,Y,Z
  1.  S (X,Z)=0,BWSC=$G(BWSC)
  1.  F  S X=$O(@BWGL@(BWDFN,11,X)) Q:'X!Z  S Y=$G(^(X,0)) D
  1.  .S S=$P(Y,U,3)
  1.  .I $L(BWSC),'$L(S)!(BWSC'[S) Q
  1.  .Q:BWDT<Y
  1.  .S Y=$P(Y,U,2)
  1.  .Q:Y&(BWDT'<Y)
  1.  .S Z=1
  1.  Q Z
  1.  ; Return Income exclusion flag
  1. INCCHK(BWDFN,BWDT) ;
  1.  ; Input: BWDT - Date of procedure
  1.  ; Returns: 0=exclude procedure; 1=include procedure
  1.  N ELGV,ELGDT
  1.  Q:'$G(BWDFN)!'$G(BWDT) 1                                              ; include procedure by default
  1.  S ELGV=+$P($G(^BWP(BWDFN,0)),U,29)                                    ; Income Eligible
  1.  S ELGDT=+$P($G(^BWP(BWDFN,0)),U,30)                                   ; Income Eligible Date
  1.  Q:'ELGV!'ELGDT 1                                                      ; include procedure by default
  1.  Q $S((ELGV=2)&(BWDT'<ELGDT):0,1:1)
  1.  ; Returns true if patient had private insurance on given date
  1. HASPI(BWDFN,BWDT) ;
  1.  Q $$PI^BWGRVLU(BWDFN,BWDT)
  1. PAPELG(BWDFN) ;
  1.  N PAPELG
  1.  S PAPELG=$$GET1^DIQ(9002086,BWDFN,.32,"I")
  1.  Q $S(PAPELG=1:1,1:0)
  1. MAMELG(BWDFN) ;
  1.  N MAMELG
  1.  S MAMELG=$$GET1^DIQ(9002086,BWDFN,.33,"I")
  1.  Q $S(MAMELG=1:1,1:0)
  1.  Q