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

BQIDCAH5.m

Go to the documentation of this file. 
  1. BQIDCAH5 ;GDIT/HS/ALA-Ad Hoc Logic Continued ; 18 Jan 2013  6:42 AM
  1.  ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1.  ;
  1. DOB(FGLOB,TGLOB,DBFROM,DBTHRU) ;EP - Date of Birth search
  1.  I $G(TGLOB)="" Q
  1.  I $G(DBFROM)="" Q
  1.  ;
  1.  NEW IEN,PDOB
  1.  S IEN=0
  1.  I $G(FGLOB)'="" D
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D
  1.  .. S PDOB=$P($G(^DPT(IEN,0)),U,3) I PDOB="" Q
  1.  .. I PDOB<DBFROM!(PDOB>DBTHRU) Q
  1.  .. S @TGLOB@(IEN)=""
  1.  ;
  1.  I $G(FGLOB)="" D
  1.  . NEW FDT,TDT
  1.  . S FDT=DBFROM-.001,TDT=DBTHRU F  S FDT=$O(^DPT("ADOB",FDT)) Q:FDT=""!(FDT>TDT)  D
  1.  .. S IEN="" F  S IEN=$O(^DPT("ADOB",FDT,IEN)) Q:'IEN  S @TGLOB@(IEN)=""
  1.  Q
  1.  ;
  1. GEN(FGLOB,TGLOB,GEN) ;EP - Gender search
  1.  I $G(TGLOB)="" Q
  1.  I $G(GEN)="" Q
  1.  ;
  1.  NEW IEN
  1.  S IEN=0
  1.  I $G(FGLOB)'="" D
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D GCHK
  1.  ;
  1.  I $G(FGLOB)="" D
  1.  . F  S IEN=$O(^AUPNPAT(IEN)) Q:'IEN  D GCHK
  1.  Q
  1.  ;
  1. GCHK ;EP  Gender check
  1.  I $P($G(^DPT(IEN,0)),U,2)'=GEN Q
  1.  S @TGLOB@(IEN)=""
  1.  Q
  1.  ;
  1. PCOMM(FGLOB,TGLOB,PCOMM) ;EP - Preferred Communication search
  1.  I $G(TGLOB)="" Q
  1.  I $G(PCOMM)="" Q
  1.  ;
  1.  NEW IEN
  1.  S IEN=0
  1.  I $G(FGLOB)'="" D
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D PCHK
  1.  ;
  1.  I $G(FGLOB)="" D
  1.  . F  S IEN=$O(^AUPNPAT(IEN)) Q:'IEN  D PCHK
  1.  Q
  1.  ;
  1. PCHK ;EP
  1.  I $P($G(^AUPNPAT(IEN,40)),U,2)'=PCOMM Q
  1.  S @TGLOB@(IEN)=""
  1.  Q
  1.  ;
  1. RACE(FGLOB,TGLOB,RACE,MPARMS) ;EP - Race search
  1.  NEW RCN
  1.  I $G(TGLOB)="" Q
  1.  I $G(RACE)]"" S RCN=$G(RACE) D RCE
  1.  I $D(MPARMS("RACE")) S RCN="" F  S RCN=$O(MPARMS("RACE",RCN)) Q:RCN=""  D RCE
  1.  Q
  1.  ;
  1. RCE ;EP
  1.  NEW IEN
  1.  I $G(FGLOB)'="" D
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D RCHK
  1.  ;
  1.  I $G(FGLOB)="" D
  1.  . S IEN=0
  1.  . F  S IEN=$O(^AUPNPAT(IEN)) Q:'IEN  D RCHK
  1.  Q
  1.  ;
  1. RCHK ;EP
  1.  ;I $G(RCN)?.N S RACE=$P(^DIC(10,RCN,0),U,1)
  1.  ;I $P($$RCE^BQIPTDMG(IEN,.01),$C(28),2)'=RACE Q
  1.  I $D(^DPT(IEN,.02,RCN)) S @TGLOB@(IEN)=""
  1.  Q
  1.  ;
  1. ETHN(FGLOB,TGLOB,ETHN,MPARMS) ;EP - Ethnicity search
  1.  NEW EN
  1.  I $G(TGLOB)="" Q
  1.  I $G(ETHN)]"" S EN=$G(ETHN) D ETH
  1.  I $D(MPARMS("ETHN")) S EN="" F  S EN=$O(MPARMS("ETHN",EN)) Q:EN=""  D ETH
  1.  Q
  1.  ;
  1. ETH ;EP
  1.  NEW IEN
  1.  S IEN=0
  1.  I $G(FGLOB)'="" D
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D ECHK
  1.  ;
  1.  I $G(FGLOB)="" D
  1.  . F  S IEN=$O(^AUPNPAT(IEN)) Q:'IEN  D ECHK
  1.  Q
  1.  ;
  1. ECHK ;EP
  1.  ;I EN?.N S ETHN=$P(^DIC(10.2,EN,0),U,1)
  1.  ;I $P($$ETHN^BQIPTDMG(IEN,.01),$C(28),2)'=ETHN Q
  1.  I $D(^DPT(IEN,.06,EN)) S @TGLOB@(IEN)=""
  1.  Q
  1.  ;
  1. PLANG(FGLOB,TGLOB,PLANG) ;EP - Preferred Language search
  1.  I $G(TGLOB)="" Q
  1.  I $G(PLANG)="" Q
  1.  ;
  1.  NEW IEN
  1.  S IEN=0
  1.  I $G(FGLOB)'="" D
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D LCHK
  1.  ;
  1.  I $G(FGLOB)="" D
  1.  . F  S IEN=$O(^AUPNPAT(IEN)) Q:'IEN  D LCHK
  1.  Q
  1.  ;
  1. LCHK ;EP
  1.  I PLANG?.N S PLANG=$P(^AUTTLANG(PLANG,0),U,1)
  1.  I $$PFLNG^BQIULPT(IEN)'=PLANG Q
  1.  S @TGLOB@(IEN)=""
  1.  Q
  1.  ;
  1. EDU(FGLOB,TGLOB,EDUC,EDUTX,FDT,TDT,EDUNOT,MPARMS) ;EP - Education search
  1.  NEW EDPT,TREF,ETAX,NGLOB,LN,RET,TOPN,TOP
  1.  S NGLOB=$NA(^TMP("BQIDCEDUC",$J)) K @NGLOB
  1.  I $G(TGLOB)="" Q
  1.  I $G(EDUC)'="" D ED
  1.  I $G(EDUTX)'="" D
  1.  . S TREF=$NA(MPARMS("EDUC"))
  1.  . K @TREF
  1.  . S ETAX=$P(@("^"_$P(EDUTX,";",2)_$P(EDUTX,";",1)_",0)"),"^",1)
  1.  . D BLD^BQITUTL(ETAX,TREF)
  1.  I $G(EDUTOP)'="" D
  1.  . S TOPN=EDUTOP,TOP=$P(^AUTTEDMT(TOPN,0),U,2)
  1.  . S LN=0
  1.  . F  S LN=$O(^AUTTEDT(LN)) Q:'LN  D
  1.  .. S RET=$G(^AUTTEDT(LN,0))
  1.  .. I RET="" Q
  1.  .. I $P(RET,U,3)'="" Q
  1.  .. I $P(RET,U,6)'=TOP Q
  1.  .. S MPARMS("EDUC",LN)=""
  1.  I $G(EDUPICK)'="" D
  1.  . S LN=0
  1.  . F  S LN=$O(^BGOEDTPR(EDUPICK,1,"B",LN)) Q:LN=""  D
  1.  .. S RET=$G(^AUTTEDT(LN,0))
  1.  .. I RET="" Q
  1.  .. I $P(RET,U,3)'="" Q
  1.  .. S MPARMS("EDUC",LN)=""
  1.  ;
  1.  I EDUOP="!" D
  1.  . I $D(MPARMS("EDUC")) S EDUC="" F  S EDUC=$O(MPARMS("EDUC",EDUC)) Q:EDUC=""  D ED
  1.  I EDUOP="&" D
  1.  . K EDPT
  1.  . S EDUC="",CT=0 F  S EDUC=$O(MPARMS("EDUC",EDUC)) Q:EDUC=""  D ED S CT=CT+1
  1.  . S IEN=""
  1.  . F  S IEN=$O(EDPT(IEN)) Q:IEN=""  D
  1.  .. S MCT=0,ED=""
  1.  .. F  S ED=$O(EDPT(IEN,ED)) Q:ED=""  S MCT=MCT+1
  1.  .. I MCT=CT,'EDUNOT S @TGLOB@(IEN)="",MIEN=EDPT(IEN,ED),@CRIT@("EDUC",IEN,MIEN)="" Q
  1.  .. I MCT=CT,EDUNOT S @NGLOB@(IEN)="" K @CRIT@("EDUC",IEN)
  1.  ;
  1.  I EDUNOT,$G(FGLOB)'="" D
  1.  . S IEN="" F  S IEN=$O(@FGLOB@(IEN)) Q:IEN=""  D
  1.  .. I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
  1.  I EDUNOT,$G(FGLOB)="" D
  1.  . S IEN=0 F  S IEN=$O(^AUPNPAT(IEN)) Q:'IEN  I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
  1.  K @NGLOB
  1.  Q
  1.  ;
  1. ED ;EP
  1.  NEW DFN,IEN
  1.  S TDT=$S(TDT'="":TDT,1:DT)
  1.  I $G(FGLOB)'="" D  Q
  1.  . NEW IEN,EDP
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D
  1.  .. I FDT="" D
  1.  ... S BDT=""
  1.  ... F  S BDT=$O(^AUPNVPED("AA",IEN,BDT)) Q:BDT=""  D EDDT
  1.  .. I FDT'="" D
  1.  ... S BGT=9999999-FDT,ENT=9999999-TDT,BDT=ENT-1
  1.  ... F  S BDT=$O(^AUPNVPED("AA",IEN,BDT)) Q:BDT=""!(BDT>BGT)  D EDDT
  1.  ;
  1.  S IEN=""
  1.  F  S IEN=$O(^AUPNVPED("B",EDUC,IEN)) Q:IEN=""  D
  1.  . I $G(^AUPNVPED(IEN,0))="" Q
  1.  . S DFN=$P(^AUPNVPED(IEN,0),U,2),VIS=$P(^AUPNVPED(IEN,0),U,3) I VIS="" Q
  1.  . I $G(^AUPNVSIT(VIS,0))="" Q
  1.  . Q:"DXCTI"[$P(^AUPNVSIT(VIS,0),U,7)
  1.  . S VSDTM=$P(^AUPNVSIT(VIS,0),U,1)\1
  1.  . I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
  1.  . I DFN'="",EDUOP="!",EDUNOT S @NGLOB@(DFN)="" Q
  1.  . I DFN'="",EDUOP="!",'EDUNOT S @TGLOB@(DFN)="",@CRIT@("EDUC",DFN,IEN)="" Q
  1.  . I DFN'="",EDUOP="&" S EDPT(DFN,EDUC)=IEN
  1.  Q
  1.  ;
  1. EDDT ;EP
  1.  S MIEN=""
  1.  F  S MIEN=$O(^AUPNVPED("AA",IEN,BDT,MIEN)) Q:MIEN=""  D
  1.  . S EDP=$P($G(^AUPNVPED(MIEN,0)),U,1)
  1.  . I EDUOP="!",EDP=EDUC,EDUNOT S @NGLOB@(IEN)="" Q
  1.  . I EDUOP="!",EDP=EDUC,'EDUNOT S @TGLOB@(IEN)="",@CRIT@("EDUC",IEN,MIEN)="" Q
  1.  . I EDUOP="&",EDP=EDUC S EDPT(IEN,EDUC)=MIEN
  1.  Q