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

BQICONPL.m

Go to the documentation of this file. 
  1. BQICONPL ;GDIT/HS/ALA-Consults by Panel ; 06 Jan 2015  4:00 PM
  1.  ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1.  ;
  1.  ;
  1.  Q
  1.  ;
  1. EN(DATA,OWNR,PLIEN,PLIST) ;EP -- BQI GET CONSULTS BY PANEL
  1.  ;Description - Entry point for the panel
  1.  ;Input Parameters
  1.  ;  OWNR  - Owner of panel
  1.  ;  PLIEN - Panel IEN
  1.  ;  PLIST - List of DFNs (optional)
  1.  NEW UID,II,DFN,HEADER,TMP,VAL,BHEADR,BVALUE,CIEN,CNIEN,CNN,CTYP,EFLDS,IFLDS,QFL,TQFL
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQICONPL",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQICONPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S CHEADR="I00010HIDE_CNIEN^",CTYP="CN"
  1.  D CHR
  1.  ; If a list of DFNs, process them instead of entire panel
  1.  I $D(PLIST)>0 D  G DONE
  1.  . I $D(PLIST)>1 D
  1.  .. S LIST="",BN=""
  1.  .. F  S BN=$O(PLIST(BN)) Q:BN=""  S LIST=LIST_PLIST(BN)
  1.  .. K PLIST S PLIST=LIST
  1.  . F BQI=1:1 S DFN=$P(PLIST,$C(28),BQI) Q:DFN=""  D
  1.  .. I $P($G(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R" Q
  1.  .. D PAT(.DATA,OWNR,PLIEN,DFN)
  1.  ;
  1.  S DFN=0
  1.  I $O(^BQICARE(OWNR,1,PLIEN,40,DFN))="" D PAT(.DATA,OWNR,PLIEN,"") G DONE
  1.  ;
  1.  F  S DFN=$O(^BQICARE(OWNR,1,PLIEN,40,DFN)) Q:'DFN  D
  1.  . I $P($G(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R" Q
  1.  . D PAT(.DATA,OWNR,PLIEN,DFN)
  1.  ;
  1. DONE ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. PAT(DATA,OWNR,PLIEN,DFN) ;EP - Build record by patient
  1.  K VALUE
  1.  D HDR^BQIHEADR(OWNR,PLIEN,DFN,.BHEADR,.BVALUE)
  1.  S VALUE(0)=BVALUE,HEADR=BHEADR_CHEADR
  1.  S HEADR=$$TKO^BQIUL1(HEADR,"^")
  1.  I II=0 S @DATA@(II)=HEADR_$C(30)
  1.  S CTYP="CN",CRE=0
  1.  ;
  1.  D CNN
  1.  S TMP=$NA(^TMP("BQICONSLT",$J)) K @TMP
  1.  I DFN'="" D CON(DFN)
  1.  ; Check for template
  1.  NEW DA,IENS,TEMPL,LYIEN,QFL,TQFL
  1.  S TEMPL=""
  1.  I OWNR'=DUZ D
  1.  . S DA=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,4,"C",CTYP,""))
  1.  . I DA="" Q
  1.  . S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=DUZ,IENS=$$IENS^DILF(.DA)
  1.  . S TEMPL=$$GET1^DIQ(90505.34,IENS,.01,"E")
  1.  I OWNR=DUZ D
  1.  . S DA=$O(^BQICARE(OWNR,1,PLIEN,4,"C",CTYP,""))
  1.  . I DA="" Q
  1.  . S DA(2)=OWNR,DA(1)=PLIEN,IENS=$$IENS^DILF(.DA)
  1.  . S TEMPL=$$GET1^DIQ(90505.14,IENS,.01,"E")
  1.  ;
  1.  ; If template, use it
  1.  I TEMPL'="" S TQFL=0 D  G FIN:'TQFL
  1.  . S LYIEN=$$TPN^BQILYUTL(DUZ,TEMPL)
  1.  . I LYIEN="" S TQFL=1 Q
  1.  . I '$D(@TMP@(123)) S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
  1.  . S CNN="" F  S CNN=$O(@TMP@(123,CNN)) Q:CNN=""  S CNIEN=$$TKO^BQIUL1(CNN,","),CRE=CRE+1,VALUE(CRE)=VALUE(0)_CNIEN_"^"
  1.  . S DOR=""
  1.  . F  S DOR=$O(^BQICARE(DUZ,15,LYIEN,1,"C",DOR)) Q:DOR=""  D
  1.  .. S IEN=""
  1.  .. F  S IEN=$O(^BQICARE(DUZ,15,LYIEN,1,"C",DOR,IEN)) Q:IEN=""  D
  1.  ... S CODE=$P(^BQICARE(DUZ,15,LYIEN,1,IEN,0),U,1)
  1.  ... S GIEN=$O(^BQI(90506.1,"B",CODE,"")) I GIEN="" Q
  1.  ... S STVW=GIEN
  1.  ... I $P(^BQI(90506.1,GIEN,0),U,10)=1 Q
  1.  ... I $$GET1^DIQ(90506.1,GIEN_",",3.01,"E")="Patient" D
  1.  .... S STVW=GIEN D CVAL
  1.  .... F C=1:1:CRE S VALUE(C)=VALUE(C)_VAL_"^"
  1.  ... I $$GET1^DIQ(90506.1,GIEN_",",3.01,"E")="Consults" D
  1.  .... I '$D(@TMP) S VALUE(CRE)=VALUE(CRE)_"^"
  1.  .... S STVW=GIEN S CNN="",C=0 F  S CNN=$O(@TMP@(123,CNN)) Q:CNN=""  D CNVL S C=C+1,VALUE(C)=VALUE(C)_VAL_"^"
  1.  . F C=1:1:CRE S VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
  1.  . I DFN="" S VALUE(1)=""
  1.  . I $D(VALUE) D
  1.  .. F C=1:1:CRE S CLNG=$L(HEADR,"^")-$L(VALUE(C),"^") D
  1.  ... I CLNG>0 S $P(VALUE(C),"^",$L(HEADR,"^"))=""
  1.  ... I CLNG<0 S VALUE(C)=$P(VALUE(C),"^",1,$L(HEADR,"^"))
  1.  .. F C=1:1:CRE S II=II+1,VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^"),@DATA@(II)=VALUE(C)_$C(30)
  1.  . K VALUE S VALUE(0)=BVALUE
  1.  ;
  1.  ; If no template, check for customized
  1.  I OWNR=DUZ D
  1.  . I DFN="" S VALUE(1)="" Q
  1.  . I '$D(@TMP) S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
  1.  . S CNN="" F  S CNN=$O(@TMP@(123,CNN)) Q:CNN=""  S CNIEN=$$TKO^BQIUL1(CNN,","),CRE=CRE+1,VALUE(CRE)=VALUE(0)_CNIEN_"^"
  1.  . S IEN=0,CIEN=$O(^BQICARE(OWNR,1,PLIEN,27,IEN))
  1.  . I CIEN'="" D  Q
  1.  .. F  S IEN=$O(^BQICARE(OWNR,1,PLIEN,27,IEN)) Q:'IEN  D
  1.  ... S CODE=$P(^BQICARE(OWNR,1,PLIEN,27,IEN,0),"^",1)
  1.  ... S SIEN=$O(^BQI(90506.1,"B",CODE,"")) I SIEN="" Q
  1.  ... I $P(^BQI(90506.1,SIEN,0),U,10)=1 Q
  1.  ... I $$GET1^DIQ(90506.1,SIEN_",",3.01,"E")="Patient" D
  1.  .... S STVW=SIEN D CVAL
  1.  .... F C=1:1:CRE S VALUE(C)=VALUE(C)_VAL_"^"
  1.  ... I $$GET1^DIQ(90506.1,SIEN_",",3.01,"E")="Consults" D
  1.  .... I '$D(@TMP) S VALUE(CRE)=VALUE(CRE)_"^"
  1.  .... S STVW=SIEN S CNN="",C=0 F  S CNN=$O(@TMP@(123,CNN)) Q:CNN=""  D CNVL S C=C+1,VALUE(C)=VALUE(C)_VAL_"^"
  1.  .. F C=1:1:CRE S VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
  1.  .. I DFN="" S VALUE(1)=""
  1.  .. I $D(VALUE) D
  1.  ... F C=1:1:CRE S CLNG=$L(HEADR,"^")-$L(VALUE(C),"^") D
  1.  .... I CLNG>0 S $P(VALUE(C),"^",$L(HEADR,"^"))=""
  1.  .... I CLNG<0 S VALUE(C)=$P(VALUE(C),"^",1,$L(HEADR,"^"))
  1.  ... F C=1:1:CRE S II=II+1,VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^"),@DATA@(II)=VALUE(C)_$C(30)
  1.  . K VALUE S VALUE(0)=BVALUE
  1.  . ;
  1.  . ; If no customized found, use default
  1.  . I CIEN="" D STAND()
  1.  ;
  1.  I OWNR'=DUZ D
  1.  . S IEN=0,CIEN=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN))
  1.  . I CIEN'="" D  Q
  1.  .. I DFN="" S VALUE(1)="" Q
  1.  .. I '$D(@TMP@(123)) S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
  1.  .. S CNN="" F  S CNN=$O(@TMP@(123,CNN)) Q:CNN=""  S CNIEN=$$TKO^BQIUL1(CNN,","),CRE=CRE+1,VALUE(CRE)=VALUE(0)_CNIEN_"^"
  1.  .. F  S IEN=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN)) Q:'IEN  D
  1.  ... S CODE=$P(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN,0),"^",1)
  1.  ... S SIEN=$O(^BQI(90506.1,"B",CODE,"")) I SIEN="" Q
  1.  ... I $P(^BQI(90506.1,SIEN,0),U,10)=1 Q
  1.  ... I $$GET1^DIQ(90506.1,SIEN_",",3.01,"E")="Patient" D
  1.  .... S STVW=SIEN D CVAL
  1.  .... F C=1:1:CRE S VALUE(C)=VALUE(C)_VAL_"^"
  1.  ... I $$GET1^DIQ(90506.1,SIEN_",",3.01,"E")="Consults" D
  1.  .... I '$D(@TMP) S VALUE(CRE)=VALUE(CRE)_"^"
  1.  .... S STVW=SIEN S CNN="",C=0 F  S CNN=$O(@TMP@(123,CNN)) Q:CNN=""  D CNVL S C=C+1,VALUE(C)=VALUE(C)_VAL_"^"
  1.  . F C=1:1:CRE S VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
  1.  . I DFN="" S VALUE(1)=""
  1.  . I $D(VALUE) D
  1.  .. F C=1:1:CRE S CLNG=$L(HEADR,"^")-$L(VALUE(C),"^") D
  1.  ... I CLNG>0 S $P(VALUE(C),"^",$L(HEADR,"^"))=""
  1.  ... I CLNG<0 S VALUE(C)=$P(VALUE(C),"^",1,$L(HEADR,"^"))
  1.  .. F C=1:1:CRE S II=II+1,VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^"),@DATA@(II)=VALUE(C)_$C(30)
  1.  . K VALUE S VALUE(0)=BVALUE
  1.  . ;
  1.  . ; If no customized found, use default
  1.  . I CIEN="" D STAND()
  1.  ;
  1. FIN ;
  1.  ;
  1.  Q
  1.  ;
  1. STAND() ;EP - Get standard display
  1.  S CRE=0
  1.  S CHEADR=BHEADR_"I00010HIDE_CNIEN^" D CSH() S HEADR=CHEADR
  1.  S CHEADR=$$TKO^BQIUL1(CHEADR,"^")
  1.  I II=0 S @DATA@(II)=CHEADR_$C(30)
  1.  I DFN="" S VALUE(1)="" Q
  1.  I '$D(@TMP) S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
  1.  S CNN="" F  S CNN=$O(@TMP@(123,CNN)) Q:CNN=""  S CNIEN=$$TKO^BQIUL1(CNN,","),CRE=CRE+1,VALUE(CRE)=VALUE(0)_CNIEN_"^"
  1.  ;
  1.  S IEN=""
  1.  F  S IEN=$O(^BQI(90506.1,"AC","D",IEN)) Q:IEN=""  D
  1.  . I $P(^BQI(90506.1,IEN,0),U,10)=1 Q
  1.  . S KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
  1.  . I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
  1.  . I $P($G(^BQI(90506.1,IEN,3)),"^",4)'="O" D
  1.  .. S STVW=IEN
  1.  .. D CVAL
  1.  .. F C=1:1:CRE S VALUE(C)=VALUE(C)_VAL_"^"
  1.  ;
  1.  S IEN=""
  1.  F  S IEN=$O(^BQI(90506.1,"AC","CN",IEN)) Q:IEN=""  D
  1.  . I $P(^BQI(90506.1,IEN,0),U,10)=1 Q
  1.  . S KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
  1.  . I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
  1.  . I $P($G(^BQI(90506.1,IEN,3)),"^",4)'="O" D
  1.  .. I '$D(@TMP) S VALUE(CRE)=VALUE(CRE)_"^"
  1.  .. S STVW=IEN S CNN="",C=0 F  S CNN=$O(@TMP@(123,CNN)) Q:CNN=""  D CNVL S C=C+1,VALUE(C)=VALUE(C)_VAL_"^"
  1.  F C=1:1:CRE S VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
  1.  I DFN="" S VALUE(1)=""
  1.  I $D(VALUE) D
  1.  . F C=1:1:CRE S CLNG=$L(HEADR,"^")-$L(VALUE(C),"^") D
  1.  .. I CLNG>0 S $P(VALUE(C),"^",$L(HEADR,"^"))=""
  1.  .. I CLNG<0 S VALUE(C)=$P(VALUE(C),"^",1,$L(HEADR,"^"))
  1.  F C=1:1:CRE S II=II+1,VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^"),@DATA@(II)=VALUE(C)_$C(30)
  1.  K VALUE S VALUE(0)=BVALUE
  1.  Q
  1.  ;
  1. CVAL ; Get demographic values
  1.  ;Parameters
  1.  ;  FIL  = FileMan file number
  1.  ;  FLD  = FileMan field number
  1.  ;  EXEC = If an executable is needed to determine value
  1.  ;  HDR  = Header value
  1.  ;the executable expects the value to be returned in variable VAL
  1.  NEW FIL,FLD,EXEC
  1.  S FIL=$P(^BQI(90506.1,STVW,0),"^",5)
  1.  S FLD=$P(^BQI(90506.1,STVW,0),"^",6)
  1.  S EXEC=$G(^BQI(90506.1,STVW,1))
  1.  S HDR=$P(^BQI(90506.1,STVW,0),"^",8)
  1.  I $G(DFN)="" S VAL="" Q
  1.  ;
  1.  I $G(EXEC)'="" X EXEC Q
  1.  ;
  1.  I FIL'="",FLD'="" S VAL=$$GET1^DIQ(FIL,DFN_",",FLD,"E")
  1.  Q
  1.  ;
  1. CON(DFN) ;EP
  1.  NEW GMRCDAT,GMRCDA,GMRCYR
  1.  I $G(IFLDS)="" D CNN
  1.  S TMP=$NA(^TMP("BQICONSLT",$J)) K @TMP
  1.  S GMRCYR=$P($G(^BQI(90508,1,16)),"^",5) I GMRCYR="" S GMRCYR="T-"_$$GET^XPAR("ALL","GMRC CONSULT LIST DAYS")
  1.  S GMRCYR=$$DATE^BQIUL1(GMRCYR)
  1.  S GMRCYR=9999999-GMRCYR,GMRCDAT=""
  1.  F  S GMRCDAT=$O(^GMR(123,"AD",DFN,GMRCDAT)) Q:'GMRCDAT!((GMRCDAT\1)>GMRCYR)  D
  1.  . S GMRCDA=""
  1.  . F  S GMRCDA=$O(^GMR(123,"AD",DFN,GMRCDAT,GMRCDA)) Q:GMRCDA=""  D
  1.  .. D GETS^DIQ(123,GMRCDA_",",IFLDS,"I",TMP)
  1.  .. D GETS^DIQ(123,GMRCDA_",",EFLDS,"E",TMP)
  1.  Q
  1.  ;
  1. CNN ;EP
  1.  NEW ORD,IEN,FLD,FIE
  1.  ;set up fields by display order
  1.  S ORD="",EFLDS="",IFLDS=""
  1.  F  S ORD=$O(^BQI(90506.1,"AD","CN",ORD)) Q:ORD=""  D
  1.  . S IEN=""
  1.  . F  S IEN=$O(^BQI(90506.1,"AD","CN",ORD,IEN)) Q:IEN=""  D
  1.  .. S FLD=$$GET1^DIQ(90506.1,IEN_",",.06,"E"),FIE=$$GET1^DIQ(90506.1,IEN_",",.2,"I")
  1.  .. I FLD="" Q
  1.  .. I FIE="" S FIE="E"
  1.  .. I FIE="E" S EFLDS=EFLDS_FLD_";"
  1.  .. I FIE="I" S IFLDS=IFLDS_FLD_";"
  1.  S EFLDS=$$TKO^BQIUL1(EFLDS,";"),IFLDS=$$TKO^BQIUL1(IFLDS,";")
  1.  Q
  1.  ;
  1. DSP() ;EP
  1.  NEW ORD,FIE,VAL
  1.  S VAL=""
  1.  S ORD=$$GET1^DIQ(90506.1,STVW_",",3.05,"E")
  1.  S FIE=$$GET1^DIQ(90506.1,STVW_",",.2,"I") S:FIE="" FIE="E"
  1.  S VAL=$G(@TMP@(123,CNN,FLD,FIE))
  1.  I FIE="I" S VAL=$$FMTMDY^BQIUL1(VAL)
  1.  Q VAL
  1.  ;
  1. CNVL ;EP
  1.  NEW FIL,FLD,EXEC
  1.  S FIL=$P(^BQI(90506.1,STVW,0),"^",5)
  1.  S FLD=$P(^BQI(90506.1,STVW,0),"^",6)
  1.  S EXEC=$G(^BQI(90506.1,STVW,1))
  1.  I $G(DFN)="" S VAL="" Q
  1.  ;
  1.  I $G(EXEC)'="" X EXEC Q
  1.  ;
  1.  I FIL'="",FLD'="" S VAL=$$GET1^DIQ(FIL,DFN_",",FLD,"E")
  1.  Q
  1.  ;
  1. PURP(CNN) ;EP - Purpose of consult
  1.  NEW VAL,N,RECORD
  1.  S VAL="",RECORD=$$TKO^BQIUL1(CNN,","),N=0
  1.  F  S N=$O(^GMR(123,RECORD,20,N)) Q:'N  D
  1.  . S VAL=VAL_^GMR(123,RECORD,20,N,0)_$C(13)_$C(10)
  1.  Q $$TKO^BQIUL1(VAL,$C(13)_$C(10))
  1.  ;
  1. CHR ;EP Consult Header
  1.  ; Check for template
  1.  NEW DA,IENS,TEMPL,LYIEN,QFL,TQFL
  1.  S TEMPL=""
  1.  I OWNR'=DUZ D
  1.  . S DA=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,4,"C",CTYP,""))
  1.  . I DA="" Q
  1.  . S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=DUZ,IENS=$$IENS^DILF(.DA)
  1.  . S TEMPL=$$GET1^DIQ(90505.34,IENS,.01,"E")
  1.  I OWNR=DUZ D
  1.  . S DA=$O(^BQICARE(OWNR,1,PLIEN,4,"C",CTYP,""))
  1.  . I DA="" Q
  1.  . S DA(2)=OWNR,DA(1)=PLIEN,IENS=$$IENS^DILF(.DA)
  1.  . S TEMPL=$$GET1^DIQ(90505.14,IENS,.01,"E")
  1.  ;
  1.  ; If template, use it
  1.  I TEMPL'="" S TQFL=0 D  G FH:'TQFL
  1.  . S LYIEN=$$TPN^BQILYUTL(DUZ,TEMPL)
  1.  . I LYIEN="" S TQFL=1 Q
  1.  . S DOR=""
  1.  . F  S DOR=$O(^BQICARE(DUZ,15,LYIEN,1,"C",DOR)) Q:DOR=""  D
  1.  .. S IEN=""
  1.  .. F  S IEN=$O(^BQICARE(DUZ,15,LYIEN,1,"C",DOR,IEN)) Q:IEN=""  D
  1.  ... S CODE=$P(^BQICARE(DUZ,15,LYIEN,1,IEN,0),U,1)
  1.  ... S GIEN=$O(^BQI(90506.1,"B",CODE,"")) I GIEN="" Q
  1.  ... S STVW=GIEN
  1.  ... I $P(^BQI(90506.1,GIEN,0),U,10)=1 Q
  1.  ... S HDR=$P(^BQI(90506.1,STVW,0),"^",8)
  1.  ... S CHEADR=CHEADR_HDR_"^"
  1.  . S CHEADR=$$TKO^BQIUL1(CHEADR,"^")
  1.  ;
  1.  ; If no template, check for customized
  1.  I OWNR=DUZ D
  1.  . S IEN=0,CIEN=$O(^BQICARE(OWNR,1,PLIEN,27,IEN))
  1.  . I CIEN'="" D  Q
  1.  .. F  S IEN=$O(^BQICARE(OWNR,1,PLIEN,27,IEN)) Q:'IEN  D
  1.  ... S CODE=$P(^BQICARE(OWNR,1,PLIEN,27,IEN,0),"^",1)
  1.  ... S SIEN=$O(^BQI(90506.1,"B",CODE,"")) I SIEN="" Q
  1.  ... I $P(^BQI(90506.1,SIEN,0),U,10)=1 Q
  1.  ... S HDR=$$GET1^DIQ(90506.1,SIEN_",",.08,"E")
  1.  ... S CHEADR=CHEADR_HDR_"^"
  1.  . S CHEADR=$$TKO^BQIUL1(CHEADR,"^")
  1.  . ;
  1.  . ; If no customized found, use default
  1.  . I CIEN="" D CSH()
  1.  ;
  1.  I OWNR'=DUZ D
  1.  . S IEN=0,CIEN=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN))
  1.  . I CIEN'="" D  Q
  1.  .. F  S IEN=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN)) Q:'IEN  D
  1.  ... S CODE=$P(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN,0),"^",1)
  1.  ... S SIEN=$O(^BQI(90506.1,"B",CODE,"")) I SIEN="" Q
  1.  ... I $P(^BQI(90506.1,SIEN,0),U,10)=1 Q
  1.  ... S HDR=$P(^BQI(90506.1,STVW,0),"^",8)
  1.  ... S CHEADR=CHEADR_HDR_"^"
  1.  . S CHEADR=$$TKO^BQIUL1(CHEADR,"^")
  1.  . ;
  1.  . ; If no customized found, use default
  1.  . I CIEN="" D CSH()
  1.  ;
  1. FH ;
  1.  Q
  1.  ;
  1. CSH() ;EP - Get standard header
  1.  S IEN=""
  1.  F  S IEN=$O(^BQI(90506.1,"AC","D",IEN)) Q:IEN=""  D
  1.  . I $P(^BQI(90506.1,IEN,0),U,10)=1 Q
  1.  . S KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
  1.  . I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
  1.  . I $P($G(^BQI(90506.1,IEN,3)),"^",4)'="O" D
  1.  .. S STVW=IEN
  1.  .. S HDR=$P(^BQI(90506.1,STVW,0),"^",8)
  1.  .. S CHEADR=CHEADR_HDR_"^"
  1.  ;
  1.  S IEN=""
  1.  F  S IEN=$O(^BQI(90506.1,"AC","CN",IEN)) Q:IEN=""  D
  1.  . I $P(^BQI(90506.1,IEN,0),U,10)=1 Q
  1.  . S KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
  1.  . I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
  1.  . I $P($G(^BQI(90506.1,IEN,3)),"^",4)'="O" D
  1.  .. S STVW=IEN
  1.  .. S HDR=$P(^BQI(90506.1,STVW,0),"^",8)
  1.  .. S CHEADR=CHEADR_HDR_"^"
  1.  S CHEADR=$$TKO^BQIUL1(CHEADR,"^")
  1.  Q