BQICONPL ;GDIT/HS/ALA-Consults by Panel ; 06 Jan 2015 4:00 PM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
;
Q
;
EN(DATA,OWNR,PLIEN,PLIST) ;EP -- BQI GET CONSULTS BY PANEL
;Description - Entry point for the panel
;Input Parameters
; OWNR - Owner of panel
; PLIEN - Panel IEN
; PLIST - List of DFNs (optional)
NEW UID,II,DFN,HEADER,TMP,VAL,BHEADR,BVALUE,CIEN,CNIEN,CNN,CTYP,EFLDS,IFLDS,QFL,TQFL
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQICONPL",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQICONPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S CHEADR="I00010HIDE_CNIEN^",CTYP="CN"
D CHR
; If a list of DFNs, process them instead of entire panel
I $D(PLIST)>0 D G DONE
. I $D(PLIST)>1 D
.. S LIST="",BN=""
.. F S BN=$O(PLIST(BN)) Q:BN="" S LIST=LIST_PLIST(BN)
.. K PLIST S PLIST=LIST
. F BQI=1:1 S DFN=$P(PLIST,$C(28),BQI) Q:DFN="" D
.. I $P($G(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R" Q
.. D PAT(.DATA,OWNR,PLIEN,DFN)
;
S DFN=0
I $O(^BQICARE(OWNR,1,PLIEN,40,DFN))="" D PAT(.DATA,OWNR,PLIEN,"") G DONE
;
F S DFN=$O(^BQICARE(OWNR,1,PLIEN,40,DFN)) Q:'DFN D
. I $P($G(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R" Q
. D PAT(.DATA,OWNR,PLIEN,DFN)
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
PAT(DATA,OWNR,PLIEN,DFN) ;EP - Build record by patient
K VALUE
D HDR^BQIHEADR(OWNR,PLIEN,DFN,.BHEADR,.BVALUE)
S VALUE(0)=BVALUE,HEADR=BHEADR_CHEADR
S HEADR=$$TKO^BQIUL1(HEADR,"^")
I II=0 S @DATA@(II)=HEADR_$C(30)
S CTYP="CN",CRE=0
;
D CNN
S TMP=$NA(^TMP("BQICONSLT",$J)) K @TMP
I DFN'="" D CON(DFN)
; Check for template
NEW DA,IENS,TEMPL,LYIEN,QFL,TQFL
S TEMPL=""
I OWNR'=DUZ D
. S DA=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,4,"C",CTYP,""))
. I DA="" Q
. S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=DUZ,IENS=$$IENS^DILF(.DA)
. S TEMPL=$$GET1^DIQ(90505.34,IENS,.01,"E")
I OWNR=DUZ D
. S DA=$O(^BQICARE(OWNR,1,PLIEN,4,"C",CTYP,""))
. I DA="" Q
. S DA(2)=OWNR,DA(1)=PLIEN,IENS=$$IENS^DILF(.DA)
. S TEMPL=$$GET1^DIQ(90505.14,IENS,.01,"E")
;
; If template, use it
I TEMPL'="" S TQFL=0 D G FIN:'TQFL
. S LYIEN=$$TPN^BQILYUTL(DUZ,TEMPL)
. I LYIEN="" S TQFL=1 Q
. I '$D(@TMP@(123)) S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
. S CNN="" F S CNN=$O(@TMP@(123,CNN)) Q:CNN="" S CNIEN=$$TKO^BQIUL1(CNN,","),CRE=CRE+1,VALUE(CRE)=VALUE(0)_CNIEN_"^"
. S DOR=""
. F S DOR=$O(^BQICARE(DUZ,15,LYIEN,1,"C",DOR)) Q:DOR="" D
.. S IEN=""
.. F S IEN=$O(^BQICARE(DUZ,15,LYIEN,1,"C",DOR,IEN)) Q:IEN="" D
... S CODE=$P(^BQICARE(DUZ,15,LYIEN,1,IEN,0),U,1)
... S GIEN=$O(^BQI(90506.1,"B",CODE,"")) I GIEN="" Q
... S STVW=GIEN
... I $P(^BQI(90506.1,GIEN,0),U,10)=1 Q
... I $$GET1^DIQ(90506.1,GIEN_",",3.01,"E")="Patient" D
.... S STVW=GIEN D CVAL
.... F C=1:1:CRE S VALUE(C)=VALUE(C)_VAL_"^"
... I $$GET1^DIQ(90506.1,GIEN_",",3.01,"E")="Consults" D
.... I '$D(@TMP) S VALUE(CRE)=VALUE(CRE)_"^"
.... 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_"^"
. F C=1:1:CRE S VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
. I DFN="" S VALUE(1)=""
. I $D(VALUE) D
.. F C=1:1:CRE S CLNG=$L(HEADR,"^")-$L(VALUE(C),"^") D
... I CLNG>0 S $P(VALUE(C),"^",$L(HEADR,"^"))=""
... I CLNG<0 S VALUE(C)=$P(VALUE(C),"^",1,$L(HEADR,"^"))
.. F C=1:1:CRE S II=II+1,VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^"),@DATA@(II)=VALUE(C)_$C(30)
. K VALUE S VALUE(0)=BVALUE
;
; If no template, check for customized
I OWNR=DUZ D
. I DFN="" S VALUE(1)="" Q
. I '$D(@TMP) S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
. S CNN="" F S CNN=$O(@TMP@(123,CNN)) Q:CNN="" S CNIEN=$$TKO^BQIUL1(CNN,","),CRE=CRE+1,VALUE(CRE)=VALUE(0)_CNIEN_"^"
. S IEN=0,CIEN=$O(^BQICARE(OWNR,1,PLIEN,27,IEN))
. I CIEN'="" D Q
.. F S IEN=$O(^BQICARE(OWNR,1,PLIEN,27,IEN)) Q:'IEN D
... S CODE=$P(^BQICARE(OWNR,1,PLIEN,27,IEN,0),"^",1)
... S SIEN=$O(^BQI(90506.1,"B",CODE,"")) I SIEN="" Q
... I $P(^BQI(90506.1,SIEN,0),U,10)=1 Q
... I $$GET1^DIQ(90506.1,SIEN_",",3.01,"E")="Patient" D
.... S STVW=SIEN D CVAL
.... F C=1:1:CRE S VALUE(C)=VALUE(C)_VAL_"^"
... I $$GET1^DIQ(90506.1,SIEN_",",3.01,"E")="Consults" D
.... I '$D(@TMP) S VALUE(CRE)=VALUE(CRE)_"^"
.... 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_"^"
.. F C=1:1:CRE S VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
.. I DFN="" S VALUE(1)=""
.. I $D(VALUE) D
... F C=1:1:CRE S CLNG=$L(HEADR,"^")-$L(VALUE(C),"^") D
.... I CLNG>0 S $P(VALUE(C),"^",$L(HEADR,"^"))=""
.... I CLNG<0 S VALUE(C)=$P(VALUE(C),"^",1,$L(HEADR,"^"))
... F C=1:1:CRE S II=II+1,VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^"),@DATA@(II)=VALUE(C)_$C(30)
. K VALUE S VALUE(0)=BVALUE
. ;
. ; If no customized found, use default
. I CIEN="" D STAND()
;
I OWNR'=DUZ D
. S IEN=0,CIEN=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN))
. I CIEN'="" D Q
.. I DFN="" S VALUE(1)="" Q
.. I '$D(@TMP@(123)) S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
.. S CNN="" F S CNN=$O(@TMP@(123,CNN)) Q:CNN="" S CNIEN=$$TKO^BQIUL1(CNN,","),CRE=CRE+1,VALUE(CRE)=VALUE(0)_CNIEN_"^"
.. F S IEN=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN)) Q:'IEN D
... S CODE=$P(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN,0),"^",1)
... S SIEN=$O(^BQI(90506.1,"B",CODE,"")) I SIEN="" Q
... I $P(^BQI(90506.1,SIEN,0),U,10)=1 Q
... I $$GET1^DIQ(90506.1,SIEN_",",3.01,"E")="Patient" D
.... S STVW=SIEN D CVAL
.... F C=1:1:CRE S VALUE(C)=VALUE(C)_VAL_"^"
... I $$GET1^DIQ(90506.1,SIEN_",",3.01,"E")="Consults" D
.... I '$D(@TMP) S VALUE(CRE)=VALUE(CRE)_"^"
.... 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_"^"
. F C=1:1:CRE S VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
. I DFN="" S VALUE(1)=""
. I $D(VALUE) D
.. F C=1:1:CRE S CLNG=$L(HEADR,"^")-$L(VALUE(C),"^") D
... I CLNG>0 S $P(VALUE(C),"^",$L(HEADR,"^"))=""
... I CLNG<0 S VALUE(C)=$P(VALUE(C),"^",1,$L(HEADR,"^"))
.. F C=1:1:CRE S II=II+1,VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^"),@DATA@(II)=VALUE(C)_$C(30)
. K VALUE S VALUE(0)=BVALUE
. ;
. ; If no customized found, use default
. I CIEN="" D STAND()
;
FIN ;
;
Q
;
STAND() ;EP - Get standard display
S CRE=0
S CHEADR=BHEADR_"I00010HIDE_CNIEN^" D CSH() S HEADR=CHEADR
S CHEADR=$$TKO^BQIUL1(CHEADR,"^")
I II=0 S @DATA@(II)=CHEADR_$C(30)
I DFN="" S VALUE(1)="" Q
I '$D(@TMP) S CRE=CRE+1,VALUE(CRE)=VALUE(0)_"^"
S CNN="" F S CNN=$O(@TMP@(123,CNN)) Q:CNN="" S CNIEN=$$TKO^BQIUL1(CNN,","),CRE=CRE+1,VALUE(CRE)=VALUE(0)_CNIEN_"^"
;
S IEN=""
F S IEN=$O(^BQI(90506.1,"AC","D",IEN)) Q:IEN="" D
. I $P(^BQI(90506.1,IEN,0),U,10)=1 Q
. S KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
. I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
. I $P($G(^BQI(90506.1,IEN,3)),"^",4)'="O" D
.. S STVW=IEN
.. D CVAL
.. F C=1:1:CRE S VALUE(C)=VALUE(C)_VAL_"^"
;
S IEN=""
F S IEN=$O(^BQI(90506.1,"AC","CN",IEN)) Q:IEN="" D
. I $P(^BQI(90506.1,IEN,0),U,10)=1 Q
. S KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
. I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
. I $P($G(^BQI(90506.1,IEN,3)),"^",4)'="O" D
.. I '$D(@TMP) S VALUE(CRE)=VALUE(CRE)_"^"
.. 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_"^"
F C=1:1:CRE S VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
I DFN="" S VALUE(1)=""
I $D(VALUE) D
. F C=1:1:CRE S CLNG=$L(HEADR,"^")-$L(VALUE(C),"^") D
.. I CLNG>0 S $P(VALUE(C),"^",$L(HEADR,"^"))=""
.. I CLNG<0 S VALUE(C)=$P(VALUE(C),"^",1,$L(HEADR,"^"))
F C=1:1:CRE S II=II+1,VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^"),@DATA@(II)=VALUE(C)_$C(30)
K VALUE S VALUE(0)=BVALUE
Q
;
CVAL ; Get demographic values
;Parameters
; FIL = FileMan file number
; FLD = FileMan field number
; EXEC = If an executable is needed to determine value
; HDR = Header value
;the executable expects the value to be returned in variable VAL
NEW FIL,FLD,EXEC
S FIL=$P(^BQI(90506.1,STVW,0),"^",5)
S FLD=$P(^BQI(90506.1,STVW,0),"^",6)
S EXEC=$G(^BQI(90506.1,STVW,1))
S HDR=$P(^BQI(90506.1,STVW,0),"^",8)
I $G(DFN)="" S VAL="" Q
;
I $G(EXEC)'="" X EXEC Q
;
I FIL'="",FLD'="" S VAL=$$GET1^DIQ(FIL,DFN_",",FLD,"E")
Q
;
CON(DFN) ;EP
NEW GMRCDAT,GMRCDA,GMRCYR
I $G(IFLDS)="" D CNN
S TMP=$NA(^TMP("BQICONSLT",$J)) K @TMP
S GMRCYR=$P($G(^BQI(90508,1,16)),"^",5) I GMRCYR="" S GMRCYR="T-"_$$GET^XPAR("ALL","GMRC CONSULT LIST DAYS")
S GMRCYR=$$DATE^BQIUL1(GMRCYR)
S GMRCYR=9999999-GMRCYR,GMRCDAT=""
F S GMRCDAT=$O(^GMR(123,"AD",DFN,GMRCDAT)) Q:'GMRCDAT!((GMRCDAT\1)>GMRCYR) D
. S GMRCDA=""
. F S GMRCDA=$O(^GMR(123,"AD",DFN,GMRCDAT,GMRCDA)) Q:GMRCDA="" D
.. D GETS^DIQ(123,GMRCDA_",",IFLDS,"I",TMP)
.. D GETS^DIQ(123,GMRCDA_",",EFLDS,"E",TMP)
Q
;
CNN ;EP
NEW ORD,IEN,FLD,FIE
;set up fields by display order
S ORD="",EFLDS="",IFLDS=""
F S ORD=$O(^BQI(90506.1,"AD","CN",ORD)) Q:ORD="" D
. S IEN=""
. F S IEN=$O(^BQI(90506.1,"AD","CN",ORD,IEN)) Q:IEN="" D
.. S FLD=$$GET1^DIQ(90506.1,IEN_",",.06,"E"),FIE=$$GET1^DIQ(90506.1,IEN_",",.2,"I")
.. I FLD="" Q
.. I FIE="" S FIE="E"
.. I FIE="E" S EFLDS=EFLDS_FLD_";"
.. I FIE="I" S IFLDS=IFLDS_FLD_";"
S EFLDS=$$TKO^BQIUL1(EFLDS,";"),IFLDS=$$TKO^BQIUL1(IFLDS,";")
Q
;
DSP() ;EP
NEW ORD,FIE,VAL
S VAL=""
S ORD=$$GET1^DIQ(90506.1,STVW_",",3.05,"E")
S FIE=$$GET1^DIQ(90506.1,STVW_",",.2,"I") S:FIE="" FIE="E"
S VAL=$G(@TMP@(123,CNN,FLD,FIE))
I FIE="I" S VAL=$$FMTMDY^BQIUL1(VAL)
Q VAL
;
CNVL ;EP
NEW FIL,FLD,EXEC
S FIL=$P(^BQI(90506.1,STVW,0),"^",5)
S FLD=$P(^BQI(90506.1,STVW,0),"^",6)
S EXEC=$G(^BQI(90506.1,STVW,1))
I $G(DFN)="" S VAL="" Q
;
I $G(EXEC)'="" X EXEC Q
;
I FIL'="",FLD'="" S VAL=$$GET1^DIQ(FIL,DFN_",",FLD,"E")
Q
;
PURP(CNN) ;EP - Purpose of consult
NEW VAL,N,RECORD
S VAL="",RECORD=$$TKO^BQIUL1(CNN,","),N=0
F S N=$O(^GMR(123,RECORD,20,N)) Q:'N D
. S VAL=VAL_^GMR(123,RECORD,20,N,0)_$C(13)_$C(10)
Q $$TKO^BQIUL1(VAL,$C(13)_$C(10))
;
CHR ;EP Consult Header
; Check for template
NEW DA,IENS,TEMPL,LYIEN,QFL,TQFL
S TEMPL=""
I OWNR'=DUZ D
. S DA=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,4,"C",CTYP,""))
. I DA="" Q
. S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=DUZ,IENS=$$IENS^DILF(.DA)
. S TEMPL=$$GET1^DIQ(90505.34,IENS,.01,"E")
I OWNR=DUZ D
. S DA=$O(^BQICARE(OWNR,1,PLIEN,4,"C",CTYP,""))
. I DA="" Q
. S DA(2)=OWNR,DA(1)=PLIEN,IENS=$$IENS^DILF(.DA)
. S TEMPL=$$GET1^DIQ(90505.14,IENS,.01,"E")
;
; If template, use it
I TEMPL'="" S TQFL=0 D G FH:'TQFL
. S LYIEN=$$TPN^BQILYUTL(DUZ,TEMPL)
. I LYIEN="" S TQFL=1 Q
. S DOR=""
. F S DOR=$O(^BQICARE(DUZ,15,LYIEN,1,"C",DOR)) Q:DOR="" D
.. S IEN=""
.. F S IEN=$O(^BQICARE(DUZ,15,LYIEN,1,"C",DOR,IEN)) Q:IEN="" D
... S CODE=$P(^BQICARE(DUZ,15,LYIEN,1,IEN,0),U,1)
... S GIEN=$O(^BQI(90506.1,"B",CODE,"")) I GIEN="" Q
... S STVW=GIEN
... I $P(^BQI(90506.1,GIEN,0),U,10)=1 Q
... S HDR=$P(^BQI(90506.1,STVW,0),"^",8)
... S CHEADR=CHEADR_HDR_"^"
. S CHEADR=$$TKO^BQIUL1(CHEADR,"^")
;
; If no template, check for customized
I OWNR=DUZ D
. S IEN=0,CIEN=$O(^BQICARE(OWNR,1,PLIEN,27,IEN))
. I CIEN'="" D Q
.. F S IEN=$O(^BQICARE(OWNR,1,PLIEN,27,IEN)) Q:'IEN D
... S CODE=$P(^BQICARE(OWNR,1,PLIEN,27,IEN,0),"^",1)
... S SIEN=$O(^BQI(90506.1,"B",CODE,"")) I SIEN="" Q
... I $P(^BQI(90506.1,SIEN,0),U,10)=1 Q
... S HDR=$$GET1^DIQ(90506.1,SIEN_",",.08,"E")
... S CHEADR=CHEADR_HDR_"^"
. S CHEADR=$$TKO^BQIUL1(CHEADR,"^")
. ;
. ; If no customized found, use default
. I CIEN="" D CSH()
;
I OWNR'=DUZ D
. S IEN=0,CIEN=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN))
. I CIEN'="" D Q
.. F S IEN=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN)) Q:'IEN D
... S CODE=$P(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN,0),"^",1)
... S SIEN=$O(^BQI(90506.1,"B",CODE,"")) I SIEN="" Q
... I $P(^BQI(90506.1,SIEN,0),U,10)=1 Q
... S HDR=$P(^BQI(90506.1,STVW,0),"^",8)
... S CHEADR=CHEADR_HDR_"^"
. S CHEADR=$$TKO^BQIUL1(CHEADR,"^")
. ;
. ; If no customized found, use default
. I CIEN="" D CSH()
;
FH ;
Q
;
CSH() ;EP - Get standard header
S IEN=""
F S IEN=$O(^BQI(90506.1,"AC","D",IEN)) Q:IEN="" D
. I $P(^BQI(90506.1,IEN,0),U,10)=1 Q
. S KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
. I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
. I $P($G(^BQI(90506.1,IEN,3)),"^",4)'="O" D
.. S STVW=IEN
.. S HDR=$P(^BQI(90506.1,STVW,0),"^",8)
.. S CHEADR=CHEADR_HDR_"^"
;
S IEN=""
F S IEN=$O(^BQI(90506.1,"AC","CN",IEN)) Q:IEN="" D
. I $P(^BQI(90506.1,IEN,0),U,10)=1 Q
. S KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
. I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
. I $P($G(^BQI(90506.1,IEN,3)),"^",4)'="O" D
.. S STVW=IEN
.. S HDR=$P(^BQI(90506.1,STVW,0),"^",8)
.. S CHEADR=CHEADR_HDR_"^"
S CHEADR=$$TKO^BQIUL1(CHEADR,"^")
Q
BQICONPL ;GDIT/HS/ALA-Consults by Panel ; 06 Jan 2015 4:00 PM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
+3 ;
+4 QUIT
+5 ;
EN(DATA,OWNR,PLIEN,PLIST) ;EP -- BQI GET CONSULTS BY PANEL
+1 ;Description - Entry point for the panel
+2 ;Input Parameters
+3 ; OWNR - Owner of panel
+4 ; PLIEN - Panel IEN
+5 ; PLIST - List of DFNs (optional)
+6 NEW UID,II,DFN,HEADER,TMP,VAL,BHEADR,BVALUE,CIEN,CNIEN,CNN,CTYP,EFLDS,IFLDS,QFL,TQFL
+7 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+8 SET DATA=$NAME(^TMP("BQICONPL",UID))
+9 KILL @DATA
+10 ;
+11 SET II=0
+12 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQICONPL D UNWIND^%ZTER"
+13 ;
+14 SET CHEADR="I00010HIDE_CNIEN^"
SET CTYP="CN"
+15 DO CHR
+16 ; If a list of DFNs, process them instead of entire panel
+17 IF $DATA(PLIST)>0
Begin DoDot:1
+18 IF $DATA(PLIST)>1
Begin DoDot:2
+19 SET LIST=""
SET BN=""
+20 FOR
SET BN=$ORDER(PLIST(BN))
IF BN=""
QUIT
SET LIST=LIST_PLIST(BN)
+21 KILL PLIST
SET PLIST=LIST
End DoDot:2
+22 FOR BQI=1:1
SET DFN=$PIECE(PLIST,$CHAR(28),BQI)
IF DFN=""
QUIT
Begin DoDot:2
+23 IF $PIECE($GET(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R"
QUIT
+24 DO PAT(.DATA,OWNR,PLIEN,DFN)
End DoDot:2
End DoDot:1
GOTO DONE
+25 ;
+26 SET DFN=0
+27 IF $ORDER(^BQICARE(OWNR,1,PLIEN,40,DFN))=""
DO PAT(.DATA,OWNR,PLIEN,"")
GOTO DONE
+28 ;
+29 FOR
SET DFN=$ORDER(^BQICARE(OWNR,1,PLIEN,40,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+30 IF $PIECE($GET(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R"
QUIT
+31 DO PAT(.DATA,OWNR,PLIEN,DFN)
End DoDot:1
+32 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
PAT(DATA,OWNR,PLIEN,DFN) ;EP - Build record by patient
+1 KILL VALUE
+2 DO HDR^BQIHEADR(OWNR,PLIEN,DFN,.BHEADR,.BVALUE)
+3 SET VALUE(0)=BVALUE
SET HEADR=BHEADR_CHEADR
+4 SET HEADR=$$TKO^BQIUL1(HEADR,"^")
+5 IF II=0
SET @DATA@(II)=HEADR_$CHAR(30)
+6 SET CTYP="CN"
SET CRE=0
+7 ;
+8 DO CNN
+9 SET TMP=$NAME(^TMP("BQICONSLT",$JOB))
KILL @TMP
+10 IF DFN'=""
DO CON(DFN)
+11 ; Check for template
+12 NEW DA,IENS,TEMPL,LYIEN,QFL,TQFL
+13 SET TEMPL=""
+14 IF OWNR'=DUZ
Begin DoDot:1
+15 SET DA=$ORDER(^BQICARE(OWNR,1,PLIEN,30,DUZ,4,"C",CTYP,""))
+16 IF DA=""
QUIT
+17 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=DUZ
SET IENS=$$IENS^DILF(.DA)
+18 SET TEMPL=$$GET1^DIQ(90505.34,IENS,.01,"E")
End DoDot:1
+19 IF OWNR=DUZ
Begin DoDot:1
+20 SET DA=$ORDER(^BQICARE(OWNR,1,PLIEN,4,"C",CTYP,""))
+21 IF DA=""
QUIT
+22 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET IENS=$$IENS^DILF(.DA)
+23 SET TEMPL=$$GET1^DIQ(90505.14,IENS,.01,"E")
End DoDot:1
+24 ;
+25 ; If template, use it
+26 IF TEMPL'=""
SET TQFL=0
Begin DoDot:1
+27 SET LYIEN=$$TPN^BQILYUTL(DUZ,TEMPL)
+28 IF LYIEN=""
SET TQFL=1
QUIT
+29 IF '$DATA(@TMP@(123))
SET CRE=CRE+1
SET VALUE(CRE)=VALUE(0)_"^"
+30 SET CNN=""
FOR
SET CNN=$ORDER(@TMP@(123,CNN))
IF CNN=""
QUIT
SET CNIEN=$$TKO^BQIUL1(CNN,",")
SET CRE=CRE+1
SET VALUE(CRE)=VALUE(0)_CNIEN_"^"
+31 SET DOR=""
+32 FOR
SET DOR=$ORDER(^BQICARE(DUZ,15,LYIEN,1,"C",DOR))
IF DOR=""
QUIT
Begin DoDot:2
+33 SET IEN=""
+34 FOR
SET IEN=$ORDER(^BQICARE(DUZ,15,LYIEN,1,"C",DOR,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+35 SET CODE=$PIECE(^BQICARE(DUZ,15,LYIEN,1,IEN,0),U,1)
+36 SET GIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
IF GIEN=""
QUIT
+37 SET STVW=GIEN
+38 IF $PIECE(^BQI(90506.1,GIEN,0),U,10)=1
QUIT
+39 IF $$GET1^DIQ(90506.1,GIEN_",",3.01,"E")="Patient"
Begin DoDot:4
+40 SET STVW=GIEN
DO CVAL
+41 FOR C=1:1:CRE
SET VALUE(C)=VALUE(C)_VAL_"^"
End DoDot:4
+42 IF $$GET1^DIQ(90506.1,GIEN_",",3.01,"E")="Consults"
Begin DoDot:4
+43 IF '$DATA(@TMP)
SET VALUE(CRE)=VALUE(CRE)_"^"
+44 SET STVW=GIEN
SET CNN=""
SET C=0
FOR
SET CNN=$ORDER(@TMP@(123,CNN))
IF CNN=""
QUIT
DO CNVL
SET C=C+1
SET VALUE(C)=VALUE(C)_VAL_"^"
End DoDot:4
End DoDot:3
End DoDot:2
+45 FOR C=1:1:CRE
SET VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
+46 IF DFN=""
SET VALUE(1)=""
+47 IF $DATA(VALUE)
Begin DoDot:2
+48 FOR C=1:1:CRE
SET CLNG=$LENGTH(HEADR,"^")-$LENGTH(VALUE(C),"^")
Begin DoDot:3
+49 IF CLNG>0
SET $PIECE(VALUE(C),"^",$LENGTH(HEADR,"^"))=""
+50 IF CLNG<0
SET VALUE(C)=$PIECE(VALUE(C),"^",1,$LENGTH(HEADR,"^"))
End DoDot:3
+51 FOR C=1:1:CRE
SET II=II+1
SET VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
SET @DATA@(II)=VALUE(C)_$CHAR(30)
End DoDot:2
+52 KILL VALUE
SET VALUE(0)=BVALUE
End DoDot:1
IF 'TQFL
GOTO FIN
+53 ;
+54 ; If no template, check for customized
+55 IF OWNR=DUZ
Begin DoDot:1
+56 IF DFN=""
SET VALUE(1)=""
QUIT
+57 IF '$DATA(@TMP)
SET CRE=CRE+1
SET VALUE(CRE)=VALUE(0)_"^"
+58 SET CNN=""
FOR
SET CNN=$ORDER(@TMP@(123,CNN))
IF CNN=""
QUIT
SET CNIEN=$$TKO^BQIUL1(CNN,",")
SET CRE=CRE+1
SET VALUE(CRE)=VALUE(0)_CNIEN_"^"
+59 SET IEN=0
SET CIEN=$ORDER(^BQICARE(OWNR,1,PLIEN,27,IEN))
+60 IF CIEN'=""
Begin DoDot:2
+61 FOR
SET IEN=$ORDER(^BQICARE(OWNR,1,PLIEN,27,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+62 SET CODE=$PIECE(^BQICARE(OWNR,1,PLIEN,27,IEN,0),"^",1)
+63 SET SIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
IF SIEN=""
QUIT
+64 IF $PIECE(^BQI(90506.1,SIEN,0),U,10)=1
QUIT
+65 IF $$GET1^DIQ(90506.1,SIEN_",",3.01,"E")="Patient"
Begin DoDot:4
+66 SET STVW=SIEN
DO CVAL
+67 FOR C=1:1:CRE
SET VALUE(C)=VALUE(C)_VAL_"^"
End DoDot:4
+68 IF $$GET1^DIQ(90506.1,SIEN_",",3.01,"E")="Consults"
Begin DoDot:4
+69 IF '$DATA(@TMP)
SET VALUE(CRE)=VALUE(CRE)_"^"
+70 SET STVW=SIEN
SET CNN=""
SET C=0
FOR
SET CNN=$ORDER(@TMP@(123,CNN))
IF CNN=""
QUIT
DO CNVL
SET C=C+1
SET VALUE(C)=VALUE(C)_VAL_"^"
End DoDot:4
End DoDot:3
+71 FOR C=1:1:CRE
SET VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
+72 IF DFN=""
SET VALUE(1)=""
+73 IF $DATA(VALUE)
Begin DoDot:3
+74 FOR C=1:1:CRE
SET CLNG=$LENGTH(HEADR,"^")-$LENGTH(VALUE(C),"^")
Begin DoDot:4
+75 IF CLNG>0
SET $PIECE(VALUE(C),"^",$LENGTH(HEADR,"^"))=""
+76 IF CLNG<0
SET VALUE(C)=$PIECE(VALUE(C),"^",1,$LENGTH(HEADR,"^"))
End DoDot:4
+77 FOR C=1:1:CRE
SET II=II+1
SET VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
SET @DATA@(II)=VALUE(C)_$CHAR(30)
End DoDot:3
End DoDot:2
QUIT
+78 KILL VALUE
SET VALUE(0)=BVALUE
+79 ;
+80 ; If no customized found, use default
+81 IF CIEN=""
DO STAND()
End DoDot:1
+82 ;
+83 IF OWNR'=DUZ
Begin DoDot:1
+84 SET IEN=0
SET CIEN=$ORDER(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN))
+85 IF CIEN'=""
Begin DoDot:2
+86 IF DFN=""
SET VALUE(1)=""
QUIT
+87 IF '$DATA(@TMP@(123))
SET CRE=CRE+1
SET VALUE(CRE)=VALUE(0)_"^"
+88 SET CNN=""
FOR
SET CNN=$ORDER(@TMP@(123,CNN))
IF CNN=""
QUIT
SET CNIEN=$$TKO^BQIUL1(CNN,",")
SET CRE=CRE+1
SET VALUE(CRE)=VALUE(0)_CNIEN_"^"
+89 FOR
SET IEN=$ORDER(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+90 SET CODE=$PIECE(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN,0),"^",1)
+91 SET SIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
IF SIEN=""
QUIT
+92 IF $PIECE(^BQI(90506.1,SIEN,0),U,10)=1
QUIT
+93 IF $$GET1^DIQ(90506.1,SIEN_",",3.01,"E")="Patient"
Begin DoDot:4
+94 SET STVW=SIEN
DO CVAL
+95 FOR C=1:1:CRE
SET VALUE(C)=VALUE(C)_VAL_"^"
End DoDot:4
+96 IF $$GET1^DIQ(90506.1,SIEN_",",3.01,"E")="Consults"
Begin DoDot:4
+97 IF '$DATA(@TMP)
SET VALUE(CRE)=VALUE(CRE)_"^"
+98 SET STVW=SIEN
SET CNN=""
SET C=0
FOR
SET CNN=$ORDER(@TMP@(123,CNN))
IF CNN=""
QUIT
DO CNVL
SET C=C+1
SET VALUE(C)=VALUE(C)_VAL_"^"
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
+99 FOR C=1:1:CRE
SET VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
+100 IF DFN=""
SET VALUE(1)=""
+101 IF $DATA(VALUE)
Begin DoDot:2
+102 FOR C=1:1:CRE
SET CLNG=$LENGTH(HEADR,"^")-$LENGTH(VALUE(C),"^")
Begin DoDot:3
+103 IF CLNG>0
SET $PIECE(VALUE(C),"^",$LENGTH(HEADR,"^"))=""
+104 IF CLNG<0
SET VALUE(C)=$PIECE(VALUE(C),"^",1,$LENGTH(HEADR,"^"))
End DoDot:3
+105 FOR C=1:1:CRE
SET II=II+1
SET VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
SET @DATA@(II)=VALUE(C)_$CHAR(30)
End DoDot:2
+106 KILL VALUE
SET VALUE(0)=BVALUE
+107 ;
+108 ; If no customized found, use default
+109 IF CIEN=""
DO STAND()
End DoDot:1
+110 ;
FIN ;
+1 ;
+2 QUIT
+3 ;
STAND() ;EP - Get standard display
+1 SET CRE=0
+2 SET CHEADR=BHEADR_"I00010HIDE_CNIEN^"
DO CSH()
SET HEADR=CHEADR
+3 SET CHEADR=$$TKO^BQIUL1(CHEADR,"^")
+4 IF II=0
SET @DATA@(II)=CHEADR_$CHAR(30)
+5 IF DFN=""
SET VALUE(1)=""
QUIT
+6 IF '$DATA(@TMP)
SET CRE=CRE+1
SET VALUE(CRE)=VALUE(0)_"^"
+7 SET CNN=""
FOR
SET CNN=$ORDER(@TMP@(123,CNN))
IF CNN=""
QUIT
SET CNIEN=$$TKO^BQIUL1(CNN,",")
SET CRE=CRE+1
SET VALUE(CRE)=VALUE(0)_CNIEN_"^"
+8 ;
+9 SET IEN=""
+10 FOR
SET IEN=$ORDER(^BQI(90506.1,"AC","D",IEN))
IF IEN=""
QUIT
Begin DoDot:1
+11 IF $PIECE(^BQI(90506.1,IEN,0),U,10)=1
QUIT
+12 SET KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
+13 IF KEY'=""
IF '$$KEYCHK^BQIULSC(KEY,DUZ)
QUIT
+14 IF $PIECE($GET(^BQI(90506.1,IEN,3)),"^",4)'="O"
Begin DoDot:2
+15 SET STVW=IEN
+16 DO CVAL
+17 FOR C=1:1:CRE
SET VALUE(C)=VALUE(C)_VAL_"^"
End DoDot:2
End DoDot:1
+18 ;
+19 SET IEN=""
+20 FOR
SET IEN=$ORDER(^BQI(90506.1,"AC","CN",IEN))
IF IEN=""
QUIT
Begin DoDot:1
+21 IF $PIECE(^BQI(90506.1,IEN,0),U,10)=1
QUIT
+22 SET KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
+23 IF KEY'=""
IF '$$KEYCHK^BQIULSC(KEY,DUZ)
QUIT
+24 IF $PIECE($GET(^BQI(90506.1,IEN,3)),"^",4)'="O"
Begin DoDot:2
+25 IF '$DATA(@TMP)
SET VALUE(CRE)=VALUE(CRE)_"^"
+26 SET STVW=IEN
SET CNN=""
SET C=0
FOR
SET CNN=$ORDER(@TMP@(123,CNN))
IF CNN=""
QUIT
DO CNVL
SET C=C+1
SET VALUE(C)=VALUE(C)_VAL_"^"
End DoDot:2
End DoDot:1
+27 FOR C=1:1:CRE
SET VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
+28 IF DFN=""
SET VALUE(1)=""
+29 IF $DATA(VALUE)
Begin DoDot:1
+30 FOR C=1:1:CRE
SET CLNG=$LENGTH(HEADR,"^")-$LENGTH(VALUE(C),"^")
Begin DoDot:2
+31 IF CLNG>0
SET $PIECE(VALUE(C),"^",$LENGTH(HEADR,"^"))=""
+32 IF CLNG<0
SET VALUE(C)=$PIECE(VALUE(C),"^",1,$LENGTH(HEADR,"^"))
End DoDot:2
End DoDot:1
+33 FOR C=1:1:CRE
SET II=II+1
SET VALUE(C)=$$TKO^BQIUL1(VALUE(C),"^")
SET @DATA@(II)=VALUE(C)_$CHAR(30)
+34 KILL VALUE
SET VALUE(0)=BVALUE
+35 QUIT
+36 ;
CVAL ; Get demographic values
+1 ;Parameters
+2 ; FIL = FileMan file number
+3 ; FLD = FileMan field number
+4 ; EXEC = If an executable is needed to determine value
+5 ; HDR = Header value
+6 ;the executable expects the value to be returned in variable VAL
+7 NEW FIL,FLD,EXEC
+8 SET FIL=$PIECE(^BQI(90506.1,STVW,0),"^",5)
+9 SET FLD=$PIECE(^BQI(90506.1,STVW,0),"^",6)
+10 SET EXEC=$GET(^BQI(90506.1,STVW,1))
+11 SET HDR=$PIECE(^BQI(90506.1,STVW,0),"^",8)
+12 IF $GET(DFN)=""
SET VAL=""
QUIT
+13 ;
+14 IF $GET(EXEC)'=""
XECUTE EXEC
QUIT
+15 ;
+16 IF FIL'=""
IF FLD'=""
SET VAL=$$GET1^DIQ(FIL,DFN_",",FLD,"E")
+17 QUIT
+18 ;
CON(DFN) ;EP
+1 NEW GMRCDAT,GMRCDA,GMRCYR
+2 IF $GET(IFLDS)=""
DO CNN
+3 SET TMP=$NAME(^TMP("BQICONSLT",$JOB))
KILL @TMP
+4 SET GMRCYR=$PIECE($GET(^BQI(90508,1,16)),"^",5)
IF GMRCYR=""
SET GMRCYR="T-"_$$GET^XPAR("ALL","GMRC CONSULT LIST DAYS")
+5 SET GMRCYR=$$DATE^BQIUL1(GMRCYR)
+6 SET GMRCYR=9999999-GMRCYR
SET GMRCDAT=""
+7 FOR
SET GMRCDAT=$ORDER(^GMR(123,"AD",DFN,GMRCDAT))
IF 'GMRCDAT!((GMRCDAT\1)>GMRCYR)
QUIT
Begin DoDot:1
+8 SET GMRCDA=""
+9 FOR
SET GMRCDA=$ORDER(^GMR(123,"AD",DFN,GMRCDAT,GMRCDA))
IF GMRCDA=""
QUIT
Begin DoDot:2
+10 DO GETS^DIQ(123,GMRCDA_",",IFLDS,"I",TMP)
+11 DO GETS^DIQ(123,GMRCDA_",",EFLDS,"E",TMP)
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
CNN ;EP
+1 NEW ORD,IEN,FLD,FIE
+2 ;set up fields by display order
+3 SET ORD=""
SET EFLDS=""
SET IFLDS=""
+4 FOR
SET ORD=$ORDER(^BQI(90506.1,"AD","CN",ORD))
IF ORD=""
QUIT
Begin DoDot:1
+5 SET IEN=""
+6 FOR
SET IEN=$ORDER(^BQI(90506.1,"AD","CN",ORD,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+7 SET FLD=$$GET1^DIQ(90506.1,IEN_",",.06,"E")
SET FIE=$$GET1^DIQ(90506.1,IEN_",",.2,"I")
+8 IF FLD=""
QUIT
+9 IF FIE=""
SET FIE="E"
+10 IF FIE="E"
SET EFLDS=EFLDS_FLD_";"
+11 IF FIE="I"
SET IFLDS=IFLDS_FLD_";"
End DoDot:2
End DoDot:1
+12 SET EFLDS=$$TKO^BQIUL1(EFLDS,";")
SET IFLDS=$$TKO^BQIUL1(IFLDS,";")
+13 QUIT
+14 ;
DSP() ;EP
+1 NEW ORD,FIE,VAL
+2 SET VAL=""
+3 SET ORD=$$GET1^DIQ(90506.1,STVW_",",3.05,"E")
+4 SET FIE=$$GET1^DIQ(90506.1,STVW_",",.2,"I")
IF FIE=""
SET FIE="E"
+5 SET VAL=$GET(@TMP@(123,CNN,FLD,FIE))
+6 IF FIE="I"
SET VAL=$$FMTMDY^BQIUL1(VAL)
+7 QUIT VAL
+8 ;
CNVL ;EP
+1 NEW FIL,FLD,EXEC
+2 SET FIL=$PIECE(^BQI(90506.1,STVW,0),"^",5)
+3 SET FLD=$PIECE(^BQI(90506.1,STVW,0),"^",6)
+4 SET EXEC=$GET(^BQI(90506.1,STVW,1))
+5 IF $GET(DFN)=""
SET VAL=""
QUIT
+6 ;
+7 IF $GET(EXEC)'=""
XECUTE EXEC
QUIT
+8 ;
+9 IF FIL'=""
IF FLD'=""
SET VAL=$$GET1^DIQ(FIL,DFN_",",FLD,"E")
+10 QUIT
+11 ;
PURP(CNN) ;EP - Purpose of consult
+1 NEW VAL,N,RECORD
+2 SET VAL=""
SET RECORD=$$TKO^BQIUL1(CNN,",")
SET N=0
+3 FOR
SET N=$ORDER(^GMR(123,RECORD,20,N))
IF 'N
QUIT
Begin DoDot:1
+4 SET VAL=VAL_^GMR(123,RECORD,20,N,0)_$CHAR(13)_$CHAR(10)
End DoDot:1
+5 QUIT $$TKO^BQIUL1(VAL,$CHAR(13)_$CHAR(10))
+6 ;
CHR ;EP Consult Header
+1 ; Check for template
+2 NEW DA,IENS,TEMPL,LYIEN,QFL,TQFL
+3 SET TEMPL=""
+4 IF OWNR'=DUZ
Begin DoDot:1
+5 SET DA=$ORDER(^BQICARE(OWNR,1,PLIEN,30,DUZ,4,"C",CTYP,""))
+6 IF DA=""
QUIT
+7 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=DUZ
SET IENS=$$IENS^DILF(.DA)
+8 SET TEMPL=$$GET1^DIQ(90505.34,IENS,.01,"E")
End DoDot:1
+9 IF OWNR=DUZ
Begin DoDot:1
+10 SET DA=$ORDER(^BQICARE(OWNR,1,PLIEN,4,"C",CTYP,""))
+11 IF DA=""
QUIT
+12 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET IENS=$$IENS^DILF(.DA)
+13 SET TEMPL=$$GET1^DIQ(90505.14,IENS,.01,"E")
End DoDot:1
+14 ;
+15 ; If template, use it
+16 IF TEMPL'=""
SET TQFL=0
Begin DoDot:1
+17 SET LYIEN=$$TPN^BQILYUTL(DUZ,TEMPL)
+18 IF LYIEN=""
SET TQFL=1
QUIT
+19 SET DOR=""
+20 FOR
SET DOR=$ORDER(^BQICARE(DUZ,15,LYIEN,1,"C",DOR))
IF DOR=""
QUIT
Begin DoDot:2
+21 SET IEN=""
+22 FOR
SET IEN=$ORDER(^BQICARE(DUZ,15,LYIEN,1,"C",DOR,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+23 SET CODE=$PIECE(^BQICARE(DUZ,15,LYIEN,1,IEN,0),U,1)
+24 SET GIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
IF GIEN=""
QUIT
+25 SET STVW=GIEN
+26 IF $PIECE(^BQI(90506.1,GIEN,0),U,10)=1
QUIT
+27 SET HDR=$PIECE(^BQI(90506.1,STVW,0),"^",8)
+28 SET CHEADR=CHEADR_HDR_"^"
End DoDot:3
End DoDot:2
+29 SET CHEADR=$$TKO^BQIUL1(CHEADR,"^")
End DoDot:1
IF 'TQFL
GOTO FH
+30 ;
+31 ; If no template, check for customized
+32 IF OWNR=DUZ
Begin DoDot:1
+33 SET IEN=0
SET CIEN=$ORDER(^BQICARE(OWNR,1,PLIEN,27,IEN))
+34 IF CIEN'=""
Begin DoDot:2
+35 FOR
SET IEN=$ORDER(^BQICARE(OWNR,1,PLIEN,27,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+36 SET CODE=$PIECE(^BQICARE(OWNR,1,PLIEN,27,IEN,0),"^",1)
+37 SET SIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
IF SIEN=""
QUIT
+38 IF $PIECE(^BQI(90506.1,SIEN,0),U,10)=1
QUIT
+39 SET HDR=$$GET1^DIQ(90506.1,SIEN_",",.08,"E")
+40 SET CHEADR=CHEADR_HDR_"^"
End DoDot:3
End DoDot:2
QUIT
+41 SET CHEADR=$$TKO^BQIUL1(CHEADR,"^")
+42 ;
+43 ; If no customized found, use default
+44 IF CIEN=""
DO CSH()
End DoDot:1
+45 ;
+46 IF OWNR'=DUZ
Begin DoDot:1
+47 SET IEN=0
SET CIEN=$ORDER(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN))
+48 IF CIEN'=""
Begin DoDot:2
+49 FOR
SET IEN=$ORDER(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+50 SET CODE=$PIECE(^BQICARE(OWNR,1,PLIEN,30,DUZ,27,IEN,0),"^",1)
+51 SET SIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
IF SIEN=""
QUIT
+52 IF $PIECE(^BQI(90506.1,SIEN,0),U,10)=1
QUIT
+53 SET HDR=$PIECE(^BQI(90506.1,STVW,0),"^",8)
+54 SET CHEADR=CHEADR_HDR_"^"
End DoDot:3
End DoDot:2
QUIT
+55 SET CHEADR=$$TKO^BQIUL1(CHEADR,"^")
+56 ;
+57 ; If no customized found, use default
+58 IF CIEN=""
DO CSH()
End DoDot:1
+59 ;
FH ;
+1 QUIT
+2 ;
CSH() ;EP - Get standard header
+1 SET IEN=""
+2 FOR
SET IEN=$ORDER(^BQI(90506.1,"AC","D",IEN))
IF IEN=""
QUIT
Begin DoDot:1
+3 IF $PIECE(^BQI(90506.1,IEN,0),U,10)=1
QUIT
+4 SET KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
+5 IF KEY'=""
IF '$$KEYCHK^BQIULSC(KEY,DUZ)
QUIT
+6 IF $PIECE($GET(^BQI(90506.1,IEN,3)),"^",4)'="O"
Begin DoDot:2
+7 SET STVW=IEN
+8 SET HDR=$PIECE(^BQI(90506.1,STVW,0),"^",8)
+9 SET CHEADR=CHEADR_HDR_"^"
End DoDot:2
End DoDot:1
+10 ;
+11 SET IEN=""
+12 FOR
SET IEN=$ORDER(^BQI(90506.1,"AC","CN",IEN))
IF IEN=""
QUIT
Begin DoDot:1
+13 IF $PIECE(^BQI(90506.1,IEN,0),U,10)=1
QUIT
+14 SET KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
+15 IF KEY'=""
IF '$$KEYCHK^BQIULSC(KEY,DUZ)
QUIT
+16 IF $PIECE($GET(^BQI(90506.1,IEN,3)),"^",4)'="O"
Begin DoDot:2
+17 SET STVW=IEN
+18 SET HDR=$PIECE(^BQI(90506.1,STVW,0),"^",8)
+19 SET CHEADR=CHEADR_HDR_"^"
End DoDot:2
End DoDot:1
+20 SET CHEADR=$$TKO^BQIUL1(CHEADR,"^")
+21 QUIT
