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

BQIREFPL.m

Go to the documentation of this file. 
  1. BQIREFPL ;GDIT/HS/ALA-Get Referrals by Panel ; 31 Dec 2014  2:27 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 REFERRALS 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,BHEADR,BVALUE,VAL,VALUE,FLDS,RFIEN,CIEN,CTYPD00015,QFL,TQFL
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIREFPL",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIREFPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S RHEADR="",CTYP="RF" D RHD
  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 BVALUE=$$TKO^BQIUL1(BVALUE,"^"),VALUE(0)=BVALUE
  1.  ;S VALUE(0)=BVALUE
  1.  S HEADR=BHEADR_RHEADR,HEADR=$$TKO^BQIUL1(HEADR,"^")
  1.  I II=0 S @DATA@(II)=HEADR_$C(30)
  1.  S CTYP="RF",CRE=0
  1.  ;
  1.  D REFF
  1.  S TMP=$NA(^TMP("BQIREFS",UID)) K @TMP
  1.  I DFN'="" D RFPT(DFN,FLDS)
  1.  ; Check for template
  1.  NEW DA,IENS,TEMPL,LYIEN,QFL
  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 DFN="" S VALUE(1)="" Q
  1.  . I '$D(@TMP@(DFN)) S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
  1.  . S RFIEN="" F  S RFIEN=$O(@TMP@(DFN,RFIEN)) Q:RFIEN=""  S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
  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")="Referrals" D
  1.  .... S RFIEN="",C=0 F  S RFIEN=$O(@TMP@(DFN,RFIEN)) Q:RFIEN=""  D RVAL(GIEN) S C=C+1,VALUE(C)=VALUE(C)_VAL_"^"
  1.  . ;
  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.  . F C=1:1:CRE S II=II+1,@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  Q
  1.  . S IEN=0,CIEN=$O(^BQICARE(OWNR,1,PLIEN,26,IEN))
  1.  . I CIEN'="" D  Q
  1.  .. I DFN="" S VALUE(1)="" Q
  1.  .. I '$D(@TMP@(DFN)) S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
  1.  .. S RFIEN="" F  S RFIEN=$O(@TMP@(DFN,RFIEN)) Q:RFIEN=""  S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
  1.  .. F  S IEN=$O(^BQICARE(OWNR,1,PLIEN,26,IEN)) Q:'IEN  D
  1.  ... S CODE=$P(^BQICARE(OWNR,1,PLIEN,26,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")="Referrals" D
  1.  .... I '$D(@TMP@(DFN)) S VALUE(CRE)=VALUE(CRE)_"^" Q
  1.  .... S RFIEN="",C=0 F  S RFIEN=$O(@TMP@(DFN,RFIEN)) Q:RFIEN=""  D RVAL(SIEN) S C=C+1,VALUE(C)=VALUE(C)_VAL_"^"
  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.  .. F C=1:1:CRE S II=II+1,@DATA@(II)=VALUE(C)_$C(30)
  1.  . K VALUE S VALUE(0)=BVALUE
  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,26,IEN))
  1.  . I CIEN'="" D  Q
  1.  .. I DFN="" S VALUE(1)="" Q
  1.  .. I '$D(@TMP@(DFN)) S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
  1.  .. S RFIEN="" F  S RFIEN=$O(@TMP@(DFN,RFIEN)) Q:RFIEN=""  S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
  1.  .. F  S IEN=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,26,IEN)) Q:'IEN  D
  1.  ... S CODE=$P(^BQICARE(OWNR,1,PLIEN,30,DUZ,26,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")="Referrals" D
  1.  .... I '$D(@TMP@(DFN)) S VALUE(CRE)=VALUE(CRE)_"^" Q
  1.  .... S RFIEN="",C=0 F  S RFIEN=$O(@TMP@(DFN,RFIEN)) Q:RFIEN=""  D RVAL(SIEN) S C=C+1,VALUE(C)=VALUE(C)_VAL_"^"
  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.  .. F C=1:1:CRE S II=II+1,@DATA@(II)=VALUE(C)_$C(30)
  1.  . K VALUE S VALUE(0)=BVALUE
  1.  . ; If no customized found, use default
  1.  . I CIEN="" D STAND()
  1.  Q
  1.  ;
  1. STAND() ;EP - Get standard display
  1.  S CRE=0
  1.  S RHEADR=BHEADR D RSH() S HEADR=RHEADR
  1.  S RHEADR=$$TKO^BQIUL1(RHEADR,"^")
  1.  I II=0 S @DATA@(II)=RHEADR_$C(30)
  1.  I '$D(@TMP) S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
  1.  S RFIEN="" F  S RFIEN=$O(@TMP@(DFN,RFIEN)) Q:RFIEN=""  S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
  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.  ;Get patient referrals
  1.  S IEN=""
  1.  F  S IEN=$O(^BQI(90506.1,"AC","RF",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.  .. I '$D(@TMP@(DFN)) S VALUE(CRE)=VALUE(CRE)_"^" Q
  1.  .. S RFIEN="",C=0 F  S RFIEN=$O(@TMP@(DFN,RFIEN)) Q:RFIEN=""  D RVAL(IEN) S C=C+1,VALUE(C)=VALUE(C)_VAL_"^"
  1.  ;
  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.  F C=1:1:CRE S II=II+1,@DATA@(II)=VALUE(C)_$C(30)
  1.  K VALUE S VALUE(0)=BVALUE
  1.  ;
  1. FIN ;
  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=$$GET1^DIQ(90506.1,STVW_",",1,"E")
  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. REFF ;EP
  1.  NEW ORD,IEN,FLD,FIE
  1.  ;set up fields by display order
  1.  S ORD="",FLDS=""
  1.  F  S ORD=$O(^BQI(90506.1,"AD","RF",ORD)) Q:ORD=""  D
  1.  . S IEN=""
  1.  . F  S IEN=$O(^BQI(90506.1,"AD","RF",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 FIE="" S FIE="E"
  1.  .. S FLDS=FLDS_FLD_"/"_FIE_";"
  1.  S FLDS=$$TKO^BQIUL1(FLDS,";")
  1.  Q
  1.  ;
  1. RFPT(DFN,FLDS) ;EP
  1.  NEW BGDT,BQIPAT
  1.  S TMP=$NA(^TMP("BQIREFS",UID)) K @TMP
  1.  S BGDT=$P($G(^BQI(90508,1,16)),"^",4) I BGDT="" S BGDT="T-12M"
  1.  S BGDT=$$DATE^BQIUL1(BGDT)
  1.  S BQIPAT(DFN)=""
  1.  D API^BMCAPI1(.BQIPAT,BGDT,"",FLDS,TMP)
  1.  K BQIPAT
  1.  ;
  1.  Q
  1.  ;
  1. RVAL(STVW) ;EP
  1.  NEW FIL,FLD,EXEC,DTY
  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 DTY=$P(^BQI(90506.1,STVW,0),"^",20)
  1.  S ORD=$P($G(^BQI(90506.1,STVW,3)),"^",5)
  1.  I $G(DFN)="" S VAL="" Q
  1.  ;
  1.  I $G(EXEC)'="" X EXEC Q
  1.  ;
  1.  I FLD'="" S VAL=$G(@TMP@(DFN,ORD,FLD,DTYP))
  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@(DFN,RFIEN,ORD,FLD,FIE))
  1.  I FIE="I" S VAL=$$FMTMDY^BQIUL1(VAL)
  1.  Q VAL
  1.  ;
  1. RHD ;EP - Referral 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 RHEADR=RHEADR_HDR_"^"
  1.  . S RHEADR=$$TKO^BQIUL1(RHEADR,"^")
  1.  ;
  1.  ; If no template, check for customized
  1.  I OWNR=DUZ D
  1.  . S IEN=0,CIEN=$O(^BQICARE(OWNR,1,PLIEN,26,IEN))
  1.  . I CIEN'="" D  Q
  1.  .. F  S IEN=$O(^BQICARE(OWNR,1,PLIEN,26,IEN)) Q:'IEN  D
  1.  ... S CODE=$P(^BQICARE(OWNR,1,PLIEN,26,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 RHEADR=RHEADR_HDR_"^"
  1.  . S RHEADR=$$TKO^BQIUL1(RHEADR,"^")
  1.  . ;
  1.  . ; If no customized found, use default
  1.  . I CIEN="" D RSH()
  1.  ;
  1.  I OWNR'=DUZ D
  1.  . S IEN=0,CIEN=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,26,IEN))
  1.  . I CIEN'="" D  Q
  1.  .. F  S IEN=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,26,IEN)) Q:'IEN  D
  1.  ... S CODE=$P(^BQICARE(OWNR,1,PLIEN,30,DUZ,26,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,SIEN,0),"^",8)
  1.  ... S RHEADR=RHEADR_HDR_"^"
  1.  . S RHEADR=$$TKO^BQIUL1(RHEADR,"^")
  1.  . ;
  1.  . ; If no customized found, use default
  1.  . I CIEN="" D RSH()
  1.  ;
  1. FH ;
  1.  Q
  1.  ;
  1. RSH() ;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 RHEADR=RHEADR_HDR_"^"
  1.  ;
  1.  S IEN=""
  1.  F  S IEN=$O(^BQI(90506.1,"AC","RF",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 RHEADR=RHEADR_HDR_"^"
  1.  S RHEADR=$$TKO^BQIUL1(RHEADR,"^")
  1.  Q