BQIRGPL ;GDIT/HS/ALA-Registers and Panels ; 01 Nov 2007 1:00 PM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
Q
;
EN(DATA,OWNR,PLIEN,CARE,PLIST) ;EP -- BQI GET REG DATA BY PANEL
;Description - Entry point for the panel
;Input Parameters
; OWNR - Owner of panel
; PLIEN - Panel IEN
; CARE - Care Management
; PLIST - List of DFNs (optional)
;
NEW UID,II,X,BQIRM,VAL,HIEN,E,J,K,L,MAX,MIN,NAFLG,BN,LIST,BQI,DFN,QFL,TQFL
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRGPL",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRGPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
; 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,CARE,DFN)
;
S DFN=0
I $O(^BQICARE(OWNR,1,PLIEN,40,DFN))="" D PAT(.DATA,OWNR,PLIEN,CARE,"") 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,CARE,DFN)
;
DONE ;
I II=0,'$D(@DATA) D PAT(.DATA,OWNR,PLIEN,CARE,"")
S II=II+1,@DATA@(II)=$C(31)
Q
;
PAT(DATA,OWNR,PLIEN,CARE,DFN) ;EP - Build record by patient
; Get standard display
NEW PCIEN,HDR,VALUE,HEADR,SENS,HDOB,Y,STVW,TEXT,ORD,GMET,GHDR,RGIEN,CRIEN,CTYP
NEW GIEN,CIEN,ATAGN,ATAGNM,ATAGST,CRN,TYP,DIS,BTREF,CODE,CT,GREF,IEN,IFL,ITIEN
NEW RES,RESULT,STOP,STVCD,TIEN,TREF,VISIT,VSDTM
S VALUE="",RGIEN=""
I DFN'="" S Y=$$GET1^DIQ(9000001,DFN_",",1102.2,"I"),HDOB=$$FMTE^BQIUL1(Y)
I DFN'="" S VALUE=DFN_U_$$FLG^BTPWPPAT(DFN)_U_$$FLG^BQIULPT(DUZ,PLIEN,DFN)_U_$$SENS^BQIULPT(DFN)_U_$$CALR^BQIULPT(DFN)_U_$$MFLAG^BQIULPT(OWNR,PLIEN,DFN)_U_HDOB_U
S HEADR="I00010DFN^T00001TICKLER_INDICATOR^T00001FLAG_INDICATOR^T00001SENS_FLAG^T00001COMM_FLAG^T00001HIDE_MANUAL^D00030HIDE_DOB^"
S HEADR=HEADR_"I00010HIDE_ASSOC_TAG_IEN^T00030HIDE_ASSOC_TAG_NAME^T00001HIDE_ASSOC_TAG_STATUS^"
;
I CARE'?.N S CRN=$O(^BQI(90506.5,"B",CARE,"")) I CRN="" Q
I CRN'="" S TYP=$P(^BQI(90506.5,CRN,0),U,2),CTYP=TYP
I CARE?.N S CRN=CARE,CARE=$P(^BQI(90506.5,CRN,0),U,1),TYP=$P(^BQI(90506.5,CRN,0),U,2),CTYP=TYP
S CRIEN=CRN
S RGIEN=$P(^BQI(90506.5,CRN,0),U,3) I RGIEN'="" S REG=$P(^BQI(90507,RGIEN,0),U,1)
S ATAGN=$P(^BQI(90506.5,CRN,0),U,11),ATAGST=""
I ATAGN="" S ATAGNM="{None}",ATAGST=""
I ATAGN'="" S ATAGNM=$P(^BQI(90506.2,ATAGN,0),U,1)
I DFN'="" S ATAGST=$$CTAG^BQITDUTL(DFN,ATAGNM)
I ATAGST="" S ATAGN="",ATAGNM="{None}"
S VALUE=VALUE_ATAGN_U_ATAGNM_U_ATAGST_U
;I DFN="" S HEADR=$$TKO^BQIUL1(HEADR,"^"),@DATA@(II)=HEADR_$C(30) Q
; Find IEN
S PCIEN=""
F S PCIEN=$O(^BQI(90506.1,"AC",CTYP,PCIEN)) Q:PCIEN="" D
. I $P(^BQI(90506.1,PCIEN,0),U,6)'=".001" Q
. S HEADR=HEADR_$P(^BQI(90506.1,PCIEN,0),U,8)_U
. I DFN="" Q
. S STVW=PCIEN
. N CRIEN ;New'd variable since it gets used in executable calls
. X ^BQI(90506.1,STVW,1)
. S VALUE=VALUE_VAL_U
;
; Check for template
NEW DA,IENS,TEMPL,LYIEN,QFL,PCIEN
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=$$DEF^BQILYUTL(OWNR,"M")
. 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 PCIEN=""
.. F S PCIEN=$O(^BQICARE(DUZ,15,LYIEN,1,"C",DOR,PCIEN)) Q:PCIEN="" D
... S CODE=$P(^BQICARE(DUZ,15,LYIEN,1,PCIEN,0),U,1)
... S GIEN=$O(^BQI(90506.1,"B",CODE,""))
... I GIEN'="" D
.... S STVW=GIEN
.... I $P($G(^BQI(90506.1,GIEN,0)),U,10)=1 Q
.... D CVAL
... I GIEN="" S IFL=0 D Q:IFL
.... S STVCD=CODE
.... D CKO
... S VALUE=VALUE_VAL_"^"
... S HEADR=HEADR_HDR_"^"
;
; If no template, check for customized
I OWNR=DUZ D
. S CIEN=$O(^BQICARE(OWNR,1,PLIEN,23,"B",CARE,""))
. I CIEN'="" D
.. S PCIEN=0
.. I $O(^BQICARE(OWNR,1,PLIEN,23,CIEN,1,PCIEN))="" D DEF Q
.. F S PCIEN=$O(^BQICARE(OWNR,1,PLIEN,23,CIEN,1,PCIEN)) Q:'PCIEN D
... S CODE=$P(^BQICARE(OWNR,1,PLIEN,23,CIEN,1,PCIEN,0),"^",1) Q:CODE=""
... S GIEN=$O(^BQI(90506.1,"B",CODE,""))
... I GIEN'="" D
.... S STVW=GIEN
.... I $P($G(^BQI(90506.1,GIEN,0)),U,10)=1 Q
.... D CVAL
... I GIEN="" S IFL=0 D Q:IFL
.... S STVCD=CODE
.... D CKO
... S VALUE=VALUE_VAL_"^"
... S HEADR=HEADR_HDR_"^"
. ;
. ; If no customized, use default
. I CIEN="" D DEF
;
I OWNR'=DUZ D
. S CIEN=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,"B",CARE,""))
. I CIEN'="" D
.. S PCIEN=0
.. I $O(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,CIEN,1,PCIEN))="" D DEF Q
.. F S PCIEN=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,CIEN,1,PCIEN)) Q:'PCIEN D
... S CODE=$P(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,CIEN,1,PCIEN,0),"^",1) Q:CODE=""
... S GIEN=$O(^BQI(90506.1,"B",CODE,""))
... I GIEN'="" D
.... S STVW=GIEN
.... I $P($G(^BQI(90506.1,GIEN,0)),U,10)=1 Q
.... K VAL
.... D CVAL
... I STVW="" S IFL=0 D Q:IFL
.... S STVCD=CODE
.... D CKO
... S HEADR=HEADR_HDR_"^"
... ;I VALUE=$$TKO^BQIUL1(VAL,";") Q
... I VALUE=$P(VAL,";"),$P(VAL,";",2)'="" S VALUE=VALUE_$P(VAL,";",2)_"^" Q
... S VALUE=VALUE_VAL_"^"
. I CIEN="" D DEF
;
FIN ; Finish
S HEADR=$$TKO^BQIUL1(HEADR,"^")
S VALUE=$$TKO^BQIUL1(VALUE,"^")
;
I DFN="" S VALUE=""
;
I II=0 S @DATA@(II)=HEADR_$C(30)
I VALUE'="",$P($G(@DATA@(II)),$C(30),1)'=VALUE S II=II+1,@DATA@(II)=VALUE_$C(30)
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,RCODE,RGIEN,RIEN,RHDR,MVALUE,CODE,GIEN
S VAL=""
;S GIEN=$O(^BQI(90506.1,"B",STVW,"")) I GIEN="" Q
S GIEN=STVW
S FIL=$$GET1^DIQ(90506.1,GIEN_",",.05,"E")
S FLD=$$GET1^DIQ(90506.1,GIEN_",",.06,"E")
S EXEC=$$GET1^DIQ(90506.1,GIEN_",",1,"E")
S HDR=$$GET1^DIQ(90506.1,GIEN_",",.08,"E")
I $G(DFN)="" S VAL="" Q
;
I $G(EXEC)'="" X EXEC Q
;
S RCODE=$$GET1^DIQ(90506.1,GIEN_",",.01,"E")
S RGIEN=$O(^BQI(90506.3,"AC",CRIEN,"")),VAL=""
I RGIEN'="" D Q:VAL'=""
. S RIEN=$O(^BQI(90506.3,RGIEN,10,"AC",RCODE,""))
. I RIEN'="",$P($G(^BQI(90506.3,RGIEN,10,RIEN,1)),U,1)="M" D Q
.. S RHDR=$P(^BQI(90506.3,RGIEN,10,RIEN,0),U,2),MVALUE=""
.. NEW SNAME,SRIEN,SORD,SXREF,SIEN
.. S SNAME=$P(^BQI(90506.3,RGIEN,10,RIEN,0),U,1)
.. S SRIEN=$O(^BQI(90506.3,"B",SNAME,"")) I SRIEN="" Q
.. S SORD="",SXREF=$S($D(^BQI(90506.3,SRIEN,10,"AF")):"AF",1:"C")
.. F S SORD=$O(^BQI(90506.3,SRIEN,10,SXREF,SORD)) Q:SORD="" D
... S SIEN=""
... F S SIEN=$O(^BQI(90506.3,SRIEN,10,SXREF,SORD,SIEN)) Q:SIEN="" D
.... I $P(^BQI(90506.3,SRIEN,10,SIEN,0),U,4)'="S" Q
.... S CODE=$P(^BQI(90506.3,SRIEN,10,SIEN,0),U,7) I CODE="" Q
.... S STVW=$O(^BQI(90506.1,"B",CODE,"")) I STVW="" Q
.... I $$GET1^DIQ(90506.1,STVW_",",.1,"I")=1 Q
.... NEW FIL,FLD,EXEC
.... S FIL=$$GET1^DIQ(90506.1,STVW_",",.05,"E")
.... S FLD=$$GET1^DIQ(90506.1,STVW_",",.06,"E")
.... S EXEC=$$GET1^DIQ(90506.1,STVW_",",1,"E")
.... S HDR=RHDR
.... I $G(DFN)="" S VAL="" Q
.... ;
.... I $G(EXEC)'="" X EXEC S VAL=VAL_$S(VAL'="":$C(10),1:"") Q
.... I FIL'="",FLD'="" S VAL=$$GET1^DIQ(FIL,DFN_",",FLD,"E")
.... S VAL=VAL_$S(VAL'="":$C(10),1:"")
.... ;S VALUE=VALUE_VAL_$S(VAL'="":$C(10),1:"")
.... ;S VAL=VALUE
... S MVALUE=MVALUE_$$TKO^BQIUL1(VAL,$C(10))
... ;S MVALUE=MVALUE_VAL
.. S VAL=MVALUE
;
I FIL'="",FLD'="" S VAL=$$GET1^DIQ(FIL,DFN_",",FLD,"E")
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
;
DEF ; Default list of fields
NEW CRIEN,TYP,ORD,PCIEN,STVW,KEY,CODE
; Check for any alternate display order which trumps source display order
S CRIEN=$$FIND1^DIC(90506.5,"","B",CARE,"","","ERROR")
S TYP=$P(^BQI(90506.5,CRIEN,0),U,2)
S ORD=""
F S ORD=$O(^BQI(90506.1,"AF",TYP,ORD)) Q:ORD="" D
. S PCIEN=""
. F S PCIEN=$O(^BQI(90506.1,"AF",TYP,ORD,PCIEN)) Q:PCIEN="" D
.. I $$GET1^DIQ(90506.1,PCIEN_",",.1,"I")=1 Q
.. S KEY=$$GET1^DIQ(90506.1,PCIEN_",",3.1,"E")
.. I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
.. I $$GET1^DIQ(90506.1,PCIEN_",",3.04,"I")'="O" D
... S CODE=$P(^BQI(90506.1,PCIEN,0),U,1) Q:CODE=""
... I $P($G(^BQI(90506.1,PCIEN,0)),U,10)=1 Q
... S STVW=PCIEN
... D CVAL
... S VALUE=VALUE_VAL_"^"
... S HEADR=HEADR_HDR_"^"
;
S CRIEN=$$FIND1^DIC(90506.5,"","B","Patient","","","ERROR")
S TYP=$P(^BQI(90506.5,CRIEN,0),U,2)
S ORD=""
F S ORD=$O(^BQI(90506.1,"AD",TYP,ORD)) Q:ORD="" D
. S PCIEN=""
. F S PCIEN=$O(^BQI(90506.1,"AD",TYP,ORD,PCIEN)) Q:PCIEN="" D
.. I $$GET1^DIQ(90506.1,PCIEN_",",.1,"I")=1 Q
.. S KEY=$$GET1^DIQ(90506.1,PCIEN_",",3.1,"E")
.. I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
.. I $$GET1^DIQ(90506.1,PCIEN_",",3.04,"I")'="O" D
... S CODE=$P(^BQI(90506.1,PCIEN,0),U,1) Q:CODE=""
... I $P($G(^BQI(90506.1,PCIEN,0)),U,10)=1 Q
... S STVW=PCIEN
... D CVAL
... S VALUE=VALUE_VAL_"^"
... S HEADR=HEADR_HDR_"^"
;
NEW CRIEN,TYP,ORD,PCIEN,STVW,KEY,CODE
S CRIEN=$$FIND1^DIC(90506.5,"","B",CARE,"","","ERROR")
S TYP=$P(^BQI(90506.5,CRIEN,0),U,2),ATAGN=$P(^BQI(90506.5,CRIEN,0),U,11)
S ORD=""
F S ORD=$O(^BQI(90506.1,"AD",TYP,ORD)) Q:ORD="" D
. S PCIEN=""
. F S PCIEN=$O(^BQI(90506.1,"AD",TYP,ORD,PCIEN)) Q:PCIEN="" D
.. I $$GET1^DIQ(90506.1,PCIEN_",",.1,"I")=1 Q
.. S KEY=$$GET1^DIQ(90506.1,PCIEN_",",3.1,"E")
.. I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
.. I $$GET1^DIQ(90506.1,PCIEN_",",3.04,"I")'="O" D
... S CODE=$P(^BQI(90506.1,PCIEN,0),U,1) Q:CODE=""
... I $P($G(^BQI(90506.1,PCIEN,0)),U,10)=1 Q
... S STVW=PCIEN
... D CVAL
... S VALUE=VALUE_VAL_"^"
... S HEADR=HEADR_HDR_"^"
;
; if additional fields
NEW CSIEN,STVCD
S CSIEN=0
F S CSIEN=$O(^BQI(90506.5,CRIEN,10,CSIEN)) Q:'CSIEN D
. S STVCD=$P(^BQI(90506.5,CRIEN,10,CSIEN,0),U,1)
. I $P(^BQI(90506.5,CRIEN,10,CSIEN,0),U,9)=1 Q
. I $P(^BQI(90506.5,CRIEN,10,CSIEN,0),U,6)'="O" D
. D CKO
. S VALUE=VALUE_VAL_"^"
. S HEADR=HEADR_HDR_"^"
; If there is a dx tag, check for additional locally added columns
I ATAGN'="" D
. NEW CSIEN,STVCD
. S CSIEN=0
. F S CSIEN=$O(^BQI(90506.2,ATAGN,6,CSIEN)) Q:'CSIEN D
.. S STVCD=$P(^BQI(90506.2,ATAGN,6,CSIEN,0),U,1)
.. I $P(^BQI(90506.2,ATAGN,6,CSIEN,0),U,9)=1 Q
.. I $P(^BQI(90506.2,ATAGN,6,CSIEN,0),U,6)'="O" D
.. D CKO
.. S VALUE=VALUE_VAL_"^"
.. S HEADR=HEADR_HDR_"^"
Q
;
CKO ; Check other
NEW BQDTFRM,RES
I $P(STVCD,"_",1)'=CTYP Q
S GIEN=$O(^BQI(90506.5,CRN,10,"B",STVCD,""))
I GIEN'="" D Q
. ;Set HEADR
. S DIS=$P(^BQI(90506.5,CRN,10,GIEN,0),U,5)
. I $P(^BQI(90506.5,CRN,10,GIEN,0),U,9)=1 S IFL=1 Q
. S BQDTFRM=$P(^BQI(90506.5,CRN,10,GIEN,0),U,8) S:BQDTFRM="" BQDTFRM="S"
. ;Get Value
. S VAL="",RES=""
. I DFN'="" S RES=$$FND^BQICMUTL(CRN,GIEN,DFN)
. ;I 'RES S HDR="T00025"_STVCD,VAL="" Q
. I DIS="" S HDR="T00025"_STVCD,VAL=RES
. I DIS="D" D
.. S HDR="T00025"_STVCD
.. S VAL=$S(BQDTFRM="S":$$FMTE^BQIUL1($P(RES,U,2)),1:$$FMTMDY^BQIUL1($P(RES,U,2)))
. I DIS="R" S HDR="T00025"_STVCD,VAL=$P(RES,U,2)
. I DIS="B" D
.. S HDR="T00025"_STVCD
.. S VAL=$S(BQDTFRM="S":$$FMTE^BQIUL1($P(RES,U,2)),1:$$FMTMDY^BQIUL1($P(RES,U,2)))_$S($P(RES,U,3)'="":" ("_$P(RES,U,3)_")",1:"")
. I VAL'="",$P(RES,U,7)="refusal" S VAL="Refused "_VAL
I GIEN="",ATAGN'="" S GIEN=$O(^BQI(90506.2,ATAGN,6,"B",STVCD,""))
I GIEN'="" D Q
. ;Set HEADR
. S DIS=$P(^BQI(90506.2,ATAGN,6,GIEN,0),U,5)
. I $P(^BQI(90506.2,ATAGN,6,GIEN,0),U,9)=1 S IFL=1 Q
. S BQDTFRM=$P(^BQI(90506.2,ATAGN,6,GIEN,0),U,8) S:BQDTFRM="" BQDTFRM="S"
. ;Get Value
. S VAL="",RES=""
. I DFN'="" S RES=$$FTAG^BQICMUTL(ATAGN,GIEN,DFN)
. ;I 'RES S HDR="T00020"_STVCD,VAL="" Q
. I DIS="D" D
.. S HDR="T00020"_STVCD
.. S VAL=$S(BQDTFRM="S":$$FMTE^BQIUL1($P(RES,U,2)),1:$$FMTMDY^BQIUL1($P(RES,U,2)))
. I DIS="R" S HDR="T00025"_STVCD,VAL=$P(RES,U,3)
. I DIS="B" D
.. S HDR="T00025"_STVCD
.. S VAL=$S(BQDTFRM="S":$$FMTE^BQIUL1($P(RES,U,2)),1:$$FMTMDY^BQIUL1($P(RES,U,2)))_" "_$P(RES,U,3)
. I VAL'="",$P(RES,U,7)="refusal" S VAL="Refused "_VAL
Q
BQIRGPL ;GDIT/HS/ALA-Registers and Panels ; 01 Nov 2007 1:00 PM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
+3 QUIT
+4 ;
EN(DATA,OWNR,PLIEN,CARE,PLIST) ;EP -- BQI GET REG DATA BY PANEL
+1 ;Description - Entry point for the panel
+2 ;Input Parameters
+3 ; OWNR - Owner of panel
+4 ; PLIEN - Panel IEN
+5 ; CARE - Care Management
+6 ; PLIST - List of DFNs (optional)
+7 ;
+8 NEW UID,II,X,BQIRM,VAL,HIEN,E,J,K,L,MAX,MIN,NAFLG,BN,LIST,BQI,DFN,QFL,TQFL
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BQIRGPL",UID))
+11 KILL @DATA
+12 ;
+13 SET II=0
+14 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRGPL D UNWIND^%ZTER"
+15 ;
+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,CARE,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,CARE,"")
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,CARE,DFN)
End DoDot:1
+32 ;
DONE ;
+1 IF II=0
IF '$DATA(@DATA)
DO PAT(.DATA,OWNR,PLIEN,CARE,"")
+2 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+3 QUIT
+4 ;
PAT(DATA,OWNR,PLIEN,CARE,DFN) ;EP - Build record by patient
+1 ; Get standard display
+2 NEW PCIEN,HDR,VALUE,HEADR,SENS,HDOB,Y,STVW,TEXT,ORD,GMET,GHDR,RGIEN,CRIEN,CTYP
+3 NEW GIEN,CIEN,ATAGN,ATAGNM,ATAGST,CRN,TYP,DIS,BTREF,CODE,CT,GREF,IEN,IFL,ITIEN
+4 NEW RES,RESULT,STOP,STVCD,TIEN,TREF,VISIT,VSDTM
+5 SET VALUE=""
SET RGIEN=""
+6 IF DFN'=""
SET Y=$$GET1^DIQ(9000001,DFN_",",1102.2,"I")
SET HDOB=$$FMTE^BQIUL1(Y)
+7 IF DFN'=""
SET VALUE=DFN_U_$$FLG^BTPWPPAT(DFN)_U_$$FLG^BQIULPT(DUZ,PLIEN,DFN)_U_$$SENS^BQIULPT(DFN)_U_$$CALR^BQIULPT(DFN)_U_$$MFLAG^BQIULPT(OWNR,PLIEN,DFN)_U_HDOB_U
+8 SET HEADR="I00010DFN^T00001TICKLER_INDICATOR^T00001FLAG_INDICATOR^T00001SENS_FLAG^T00001COMM_FLAG^T00001HIDE_MANUAL^D00030HIDE_DOB^"
+9 SET HEADR=HEADR_"I00010HIDE_ASSOC_TAG_IEN^T00030HIDE_ASSOC_TAG_NAME^T00001HIDE_ASSOC_TAG_STATUS^"
+10 ;
+11 IF CARE'?.N
SET CRN=$ORDER(^BQI(90506.5,"B",CARE,""))
IF CRN=""
QUIT
+12 IF CRN'=""
SET TYP=$PIECE(^BQI(90506.5,CRN,0),U,2)
SET CTYP=TYP
+13 IF CARE?.N
SET CRN=CARE
SET CARE=$PIECE(^BQI(90506.5,CRN,0),U,1)
SET TYP=$PIECE(^BQI(90506.5,CRN,0),U,2)
SET CTYP=TYP
+14 SET CRIEN=CRN
+15 SET RGIEN=$PIECE(^BQI(90506.5,CRN,0),U,3)
IF RGIEN'=""
SET REG=$PIECE(^BQI(90507,RGIEN,0),U,1)
+16 SET ATAGN=$PIECE(^BQI(90506.5,CRN,0),U,11)
SET ATAGST=""
+17 IF ATAGN=""
SET ATAGNM="{None}"
SET ATAGST=""
+18 IF ATAGN'=""
SET ATAGNM=$PIECE(^BQI(90506.2,ATAGN,0),U,1)
+19 IF DFN'=""
SET ATAGST=$$CTAG^BQITDUTL(DFN,ATAGNM)
+20 IF ATAGST=""
SET ATAGN=""
SET ATAGNM="{None}"
+21 SET VALUE=VALUE_ATAGN_U_ATAGNM_U_ATAGST_U
+22 ;I DFN="" S HEADR=$$TKO^BQIUL1(HEADR,"^"),@DATA@(II)=HEADR_$C(30) Q
+23 ; Find IEN
+24 SET PCIEN=""
+25 FOR
SET PCIEN=$ORDER(^BQI(90506.1,"AC",CTYP,PCIEN))
IF PCIEN=""
QUIT
Begin DoDot:1
+26 IF $PIECE(^BQI(90506.1,PCIEN,0),U,6)'=".001"
QUIT
+27 SET HEADR=HEADR_$PIECE(^BQI(90506.1,PCIEN,0),U,8)_U
+28 IF DFN=""
QUIT
+29 SET STVW=PCIEN
+30 ;New'd variable since it gets used in executable calls
NEW CRIEN
+31 XECUTE ^BQI(90506.1,STVW,1)
+32 SET VALUE=VALUE_VAL_U
End DoDot:1
+33 ;
+34 ; Check for template
+35 NEW DA,IENS,TEMPL,LYIEN,QFL,PCIEN
+36 SET TEMPL=""
+37 IF OWNR'=DUZ
Begin DoDot:1
+38 SET DA=$ORDER(^BQICARE(OWNR,1,PLIEN,30,DUZ,4,"C",CTYP,""))
+39 IF DA=""
QUIT
+40 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=DUZ
SET IENS=$$IENS^DILF(.DA)
+41 SET TEMPL=$$GET1^DIQ(90505.34,IENS,.01,"E")
End DoDot:1
+42 IF OWNR=DUZ
Begin DoDot:1
+43 SET DA=$ORDER(^BQICARE(OWNR,1,PLIEN,4,"C",CTYP,""))
+44 IF DA=""
QUIT
+45 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET IENS=$$IENS^DILF(.DA)
+46 SET TEMPL=$$GET1^DIQ(90505.14,IENS,.01,"E")
End DoDot:1
+47 ;
+48 ; If template, use it
+49 IF TEMPL'=""
SET TQFL=0
Begin DoDot:1
+50 ;S LYIEN=$$DEF^BQILYUTL(OWNR,"M")
+51 SET LYIEN=$$TPN^BQILYUTL(DUZ,TEMPL)
+52 IF LYIEN=""
SET TQFL=1
QUIT
+53 SET DOR=""
+54 FOR
SET DOR=$ORDER(^BQICARE(DUZ,15,LYIEN,1,"C",DOR))
IF DOR=""
QUIT
Begin DoDot:2
+55 SET PCIEN=""
+56 FOR
SET PCIEN=$ORDER(^BQICARE(DUZ,15,LYIEN,1,"C",DOR,PCIEN))
IF PCIEN=""
QUIT
Begin DoDot:3
+57 SET CODE=$PIECE(^BQICARE(DUZ,15,LYIEN,1,PCIEN,0),U,1)
+58 SET GIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
+59 IF GIEN'=""
Begin DoDot:4
+60 SET STVW=GIEN
+61 IF $PIECE($GET(^BQI(90506.1,GIEN,0)),U,10)=1
QUIT
+62 DO CVAL
End DoDot:4
+63 IF GIEN=""
SET IFL=0
Begin DoDot:4
+64 SET STVCD=CODE
+65 DO CKO
End DoDot:4
IF IFL
QUIT
+66 SET VALUE=VALUE_VAL_"^"
+67 SET HEADR=HEADR_HDR_"^"
End DoDot:3
End DoDot:2
End DoDot:1
IF 'TQFL
GOTO FIN
+68 ;
+69 ; If no template, check for customized
+70 IF OWNR=DUZ
Begin DoDot:1
+71 SET CIEN=$ORDER(^BQICARE(OWNR,1,PLIEN,23,"B",CARE,""))
+72 IF CIEN'=""
Begin DoDot:2
+73 SET PCIEN=0
+74 IF $ORDER(^BQICARE(OWNR,1,PLIEN,23,CIEN,1,PCIEN))=""
DO DEF
QUIT
+75 FOR
SET PCIEN=$ORDER(^BQICARE(OWNR,1,PLIEN,23,CIEN,1,PCIEN))
IF 'PCIEN
QUIT
Begin DoDot:3
+76 SET CODE=$PIECE(^BQICARE(OWNR,1,PLIEN,23,CIEN,1,PCIEN,0),"^",1)
IF CODE=""
QUIT
+77 SET GIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
+78 IF GIEN'=""
Begin DoDot:4
+79 SET STVW=GIEN
+80 IF $PIECE($GET(^BQI(90506.1,GIEN,0)),U,10)=1
QUIT
+81 DO CVAL
End DoDot:4
+82 IF GIEN=""
SET IFL=0
Begin DoDot:4
+83 SET STVCD=CODE
+84 DO CKO
End DoDot:4
IF IFL
QUIT
+85 SET VALUE=VALUE_VAL_"^"
+86 SET HEADR=HEADR_HDR_"^"
End DoDot:3
End DoDot:2
+87 ;
+88 ; If no customized, use default
+89 IF CIEN=""
DO DEF
End DoDot:1
+90 ;
+91 IF OWNR'=DUZ
Begin DoDot:1
+92 SET CIEN=$ORDER(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,"B",CARE,""))
+93 IF CIEN'=""
Begin DoDot:2
+94 SET PCIEN=0
+95 IF $ORDER(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,CIEN,1,PCIEN))=""
DO DEF
QUIT
+96 FOR
SET PCIEN=$ORDER(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,CIEN,1,PCIEN))
IF 'PCIEN
QUIT
Begin DoDot:3
+97 SET CODE=$PIECE(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,CIEN,1,PCIEN,0),"^",1)
IF CODE=""
QUIT
+98 SET GIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
+99 IF GIEN'=""
Begin DoDot:4
+100 SET STVW=GIEN
+101 IF $PIECE($GET(^BQI(90506.1,GIEN,0)),U,10)=1
QUIT
+102 KILL VAL
+103 DO CVAL
End DoDot:4
+104 IF STVW=""
SET IFL=0
Begin DoDot:4
+105 SET STVCD=CODE
+106 DO CKO
End DoDot:4
IF IFL
QUIT
+107 SET HEADR=HEADR_HDR_"^"
+108 ;I VALUE=$$TKO^BQIUL1(VAL,";") Q
+109 IF VALUE=$PIECE(VAL,";")
IF $PIECE(VAL,";",2)'=""
SET VALUE=VALUE_$PIECE(VAL,";",2)_"^"
QUIT
+110 SET VALUE=VALUE_VAL_"^"
End DoDot:3
End DoDot:2
+111 IF CIEN=""
DO DEF
End DoDot:1
+112 ;
FIN ; Finish
+1 SET HEADR=$$TKO^BQIUL1(HEADR,"^")
+2 SET VALUE=$$TKO^BQIUL1(VALUE,"^")
+3 ;
+4 IF DFN=""
SET VALUE=""
+5 ;
+6 IF II=0
SET @DATA@(II)=HEADR_$CHAR(30)
+7 IF VALUE'=""
IF $PIECE($GET(@DATA@(II)),$CHAR(30),1)'=VALUE
SET II=II+1
SET @DATA@(II)=VALUE_$CHAR(30)
+8 QUIT
+9 ;
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,RCODE,RGIEN,RIEN,RHDR,MVALUE,CODE,GIEN
+8 SET VAL=""
+9 ;S GIEN=$O(^BQI(90506.1,"B",STVW,"")) I GIEN="" Q
+10 SET GIEN=STVW
+11 SET FIL=$$GET1^DIQ(90506.1,GIEN_",",.05,"E")
+12 SET FLD=$$GET1^DIQ(90506.1,GIEN_",",.06,"E")
+13 SET EXEC=$$GET1^DIQ(90506.1,GIEN_",",1,"E")
+14 SET HDR=$$GET1^DIQ(90506.1,GIEN_",",.08,"E")
+15 IF $GET(DFN)=""
SET VAL=""
QUIT
+16 ;
+17 IF $GET(EXEC)'=""
XECUTE EXEC
QUIT
+18 ;
+19 SET RCODE=$$GET1^DIQ(90506.1,GIEN_",",.01,"E")
+20 SET RGIEN=$ORDER(^BQI(90506.3,"AC",CRIEN,""))
SET VAL=""
+21 IF RGIEN'=""
Begin DoDot:1
+22 SET RIEN=$ORDER(^BQI(90506.3,RGIEN,10,"AC",RCODE,""))
+23 IF RIEN'=""
IF $PIECE($GET(^BQI(90506.3,RGIEN,10,RIEN,1)),U,1)="M"
Begin DoDot:2
+24 SET RHDR=$PIECE(^BQI(90506.3,RGIEN,10,RIEN,0),U,2)
SET MVALUE=""
+25 NEW SNAME,SRIEN,SORD,SXREF,SIEN
+26 SET SNAME=$PIECE(^BQI(90506.3,RGIEN,10,RIEN,0),U,1)
+27 SET SRIEN=$ORDER(^BQI(90506.3,"B",SNAME,""))
IF SRIEN=""
QUIT
+28 SET SORD=""
SET SXREF=$SELECT($DATA(^BQI(90506.3,SRIEN,10,"AF")):"AF",1:"C")
+29 FOR
SET SORD=$ORDER(^BQI(90506.3,SRIEN,10,SXREF,SORD))
IF SORD=""
QUIT
Begin DoDot:3
+30 SET SIEN=""
+31 FOR
SET SIEN=$ORDER(^BQI(90506.3,SRIEN,10,SXREF,SORD,SIEN))
IF SIEN=""
QUIT
Begin DoDot:4
+32 IF $PIECE(^BQI(90506.3,SRIEN,10,SIEN,0),U,4)'="S"
QUIT
+33 SET CODE=$PIECE(^BQI(90506.3,SRIEN,10,SIEN,0),U,7)
IF CODE=""
QUIT
+34 SET STVW=$ORDER(^BQI(90506.1,"B",CODE,""))
IF STVW=""
QUIT
+35 IF $$GET1^DIQ(90506.1,STVW_",",.1,"I")=1
QUIT
+36 NEW FIL,FLD,EXEC
+37 SET FIL=$$GET1^DIQ(90506.1,STVW_",",.05,"E")
+38 SET FLD=$$GET1^DIQ(90506.1,STVW_",",.06,"E")
+39 SET EXEC=$$GET1^DIQ(90506.1,STVW_",",1,"E")
+40 SET HDR=RHDR
+41 IF $GET(DFN)=""
SET VAL=""
QUIT
+42 ;
+43 IF $GET(EXEC)'=""
XECUTE EXEC
SET VAL=VAL_$SELECT(VAL'="":$CHAR(10),1:"")
QUIT
+44 IF FIL'=""
IF FLD'=""
SET VAL=$$GET1^DIQ(FIL,DFN_",",FLD,"E")
+45 SET VAL=VAL_$SELECT(VAL'="":$CHAR(10),1:"")
+46 ;S VALUE=VALUE_VAL_$S(VAL'="":$C(10),1:"")
+47 ;S VAL=VALUE
End DoDot:4
+48 SET MVALUE=MVALUE_$$TKO^BQIUL1(VAL,$CHAR(10))
+49 ;S MVALUE=MVALUE_VAL
End DoDot:3
+50 SET VAL=MVALUE
End DoDot:2
QUIT
End DoDot:1
IF VAL'=""
QUIT
+51 ;
+52 IF FIL'=""
IF FLD'=""
SET VAL=$$GET1^DIQ(FIL,DFN_",",FLD,"E")
+53 QUIT
+54 ;
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 ;
DEF ; Default list of fields
+1 NEW CRIEN,TYP,ORD,PCIEN,STVW,KEY,CODE
+2 ; Check for any alternate display order which trumps source display order
+3 SET CRIEN=$$FIND1^DIC(90506.5,"","B",CARE,"","","ERROR")
+4 SET TYP=$PIECE(^BQI(90506.5,CRIEN,0),U,2)
+5 SET ORD=""
+6 FOR
SET ORD=$ORDER(^BQI(90506.1,"AF",TYP,ORD))
IF ORD=""
QUIT
Begin DoDot:1
+7 SET PCIEN=""
+8 FOR
SET PCIEN=$ORDER(^BQI(90506.1,"AF",TYP,ORD,PCIEN))
IF PCIEN=""
QUIT
Begin DoDot:2
+9 IF $$GET1^DIQ(90506.1,PCIEN_",",.1,"I")=1
QUIT
+10 SET KEY=$$GET1^DIQ(90506.1,PCIEN_",",3.1,"E")
+11 IF KEY'=""
IF '$$KEYCHK^BQIULSC(KEY,DUZ)
QUIT
+12 IF $$GET1^DIQ(90506.1,PCIEN_",",3.04,"I")'="O"
Begin DoDot:3
+13 SET CODE=$PIECE(^BQI(90506.1,PCIEN,0),U,1)
IF CODE=""
QUIT
+14 IF $PIECE($GET(^BQI(90506.1,PCIEN,0)),U,10)=1
QUIT
+15 SET STVW=PCIEN
+16 DO CVAL
+17 SET VALUE=VALUE_VAL_"^"
+18 SET HEADR=HEADR_HDR_"^"
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;
+20 SET CRIEN=$$FIND1^DIC(90506.5,"","B","Patient","","","ERROR")
+21 SET TYP=$PIECE(^BQI(90506.5,CRIEN,0),U,2)
+22 SET ORD=""
+23 FOR
SET ORD=$ORDER(^BQI(90506.1,"AD",TYP,ORD))
IF ORD=""
QUIT
Begin DoDot:1
+24 SET PCIEN=""
+25 FOR
SET PCIEN=$ORDER(^BQI(90506.1,"AD",TYP,ORD,PCIEN))
IF PCIEN=""
QUIT
Begin DoDot:2
+26 IF $$GET1^DIQ(90506.1,PCIEN_",",.1,"I")=1
QUIT
+27 SET KEY=$$GET1^DIQ(90506.1,PCIEN_",",3.1,"E")
+28 IF KEY'=""
IF '$$KEYCHK^BQIULSC(KEY,DUZ)
QUIT
+29 IF $$GET1^DIQ(90506.1,PCIEN_",",3.04,"I")'="O"
Begin DoDot:3
+30 SET CODE=$PIECE(^BQI(90506.1,PCIEN,0),U,1)
IF CODE=""
QUIT
+31 IF $PIECE($GET(^BQI(90506.1,PCIEN,0)),U,10)=1
QUIT
+32 SET STVW=PCIEN
+33 DO CVAL
+34 SET VALUE=VALUE_VAL_"^"
+35 SET HEADR=HEADR_HDR_"^"
End DoDot:3
End DoDot:2
End DoDot:1
+36 ;
+37 NEW CRIEN,TYP,ORD,PCIEN,STVW,KEY,CODE
+38 SET CRIEN=$$FIND1^DIC(90506.5,"","B",CARE,"","","ERROR")
+39 SET TYP=$PIECE(^BQI(90506.5,CRIEN,0),U,2)
SET ATAGN=$PIECE(^BQI(90506.5,CRIEN,0),U,11)
+40 SET ORD=""
+41 FOR
SET ORD=$ORDER(^BQI(90506.1,"AD",TYP,ORD))
IF ORD=""
QUIT
Begin DoDot:1
+42 SET PCIEN=""
+43 FOR
SET PCIEN=$ORDER(^BQI(90506.1,"AD",TYP,ORD,PCIEN))
IF PCIEN=""
QUIT
Begin DoDot:2
+44 IF $$GET1^DIQ(90506.1,PCIEN_",",.1,"I")=1
QUIT
+45 SET KEY=$$GET1^DIQ(90506.1,PCIEN_",",3.1,"E")
+46 IF KEY'=""
IF '$$KEYCHK^BQIULSC(KEY,DUZ)
QUIT
+47 IF $$GET1^DIQ(90506.1,PCIEN_",",3.04,"I")'="O"
Begin DoDot:3
+48 SET CODE=$PIECE(^BQI(90506.1,PCIEN,0),U,1)
IF CODE=""
QUIT
+49 IF $PIECE($GET(^BQI(90506.1,PCIEN,0)),U,10)=1
QUIT
+50 SET STVW=PCIEN
+51 DO CVAL
+52 SET VALUE=VALUE_VAL_"^"
+53 SET HEADR=HEADR_HDR_"^"
End DoDot:3
End DoDot:2
End DoDot:1
+54 ;
+55 ; if additional fields
+56 NEW CSIEN,STVCD
+57 SET CSIEN=0
+58 FOR
SET CSIEN=$ORDER(^BQI(90506.5,CRIEN,10,CSIEN))
IF 'CSIEN
QUIT
Begin DoDot:1
+59 SET STVCD=$PIECE(^BQI(90506.5,CRIEN,10,CSIEN,0),U,1)
+60 IF $PIECE(^BQI(90506.5,CRIEN,10,CSIEN,0),U,9)=1
QUIT
+61 IF $PIECE(^BQI(90506.5,CRIEN,10,CSIEN,0),U,6)'="O"
Begin DoDot:2
End DoDot:2
+62 DO CKO
+63 SET VALUE=VALUE_VAL_"^"
+64 SET HEADR=HEADR_HDR_"^"
End DoDot:1
+65 ; If there is a dx tag, check for additional locally added columns
+66 IF ATAGN'=""
Begin DoDot:1
+67 NEW CSIEN,STVCD
+68 SET CSIEN=0
+69 FOR
SET CSIEN=$ORDER(^BQI(90506.2,ATAGN,6,CSIEN))
IF 'CSIEN
QUIT
Begin DoDot:2
+70 SET STVCD=$PIECE(^BQI(90506.2,ATAGN,6,CSIEN,0),U,1)
+71 IF $PIECE(^BQI(90506.2,ATAGN,6,CSIEN,0),U,9)=1
QUIT
+72 IF $PIECE(^BQI(90506.2,ATAGN,6,CSIEN,0),U,6)'="O"
Begin DoDot:3
End DoDot:3
+73 DO CKO
+74 SET VALUE=VALUE_VAL_"^"
+75 SET HEADR=HEADR_HDR_"^"
End DoDot:2
End DoDot:1
+76 QUIT
+77 ;
CKO ; Check other
+1 NEW BQDTFRM,RES
+2 IF $PIECE(STVCD,"_",1)'=CTYP
QUIT
+3 SET GIEN=$ORDER(^BQI(90506.5,CRN,10,"B",STVCD,""))
+4 IF GIEN'=""
Begin DoDot:1
+5 ;Set HEADR
+6 SET DIS=$PIECE(^BQI(90506.5,CRN,10,GIEN,0),U,5)
+7 IF $PIECE(^BQI(90506.5,CRN,10,GIEN,0),U,9)=1
SET IFL=1
QUIT
+8 SET BQDTFRM=$PIECE(^BQI(90506.5,CRN,10,GIEN,0),U,8)
IF BQDTFRM=""
SET BQDTFRM="S"
+9 ;Get Value
+10 SET VAL=""
SET RES=""
+11 IF DFN'=""
SET RES=$$FND^BQICMUTL(CRN,GIEN,DFN)
+12 ;I 'RES S HDR="T00025"_STVCD,VAL="" Q
+13 IF DIS=""
SET HDR="T00025"_STVCD
SET VAL=RES
+14 IF DIS="D"
Begin DoDot:2
+15 SET HDR="T00025"_STVCD
+16 SET VAL=$SELECT(BQDTFRM="S":$$FMTE^BQIUL1($PIECE(RES,U,2)),1:$$FMTMDY^BQIUL1($PIECE(RES,U,2)))
End DoDot:2
+17 IF DIS="R"
SET HDR="T00025"_STVCD
SET VAL=$PIECE(RES,U,2)
+18 IF DIS="B"
Begin DoDot:2
+19 SET HDR="T00025"_STVCD
+20 SET VAL=$SELECT(BQDTFRM="S":$$FMTE^BQIUL1($PIECE(RES,U,2)),1:$$FMTMDY^BQIUL1($PIECE(RES,U,2)))_$SELECT($PIECE(RES,U,3)'="":" ("_$PIECE(RES,U,3)_")",1:"")
End DoDot:2
+21 IF VAL'=""
IF $PIECE(RES,U,7)="refusal"
SET VAL="Refused "_VAL
End DoDot:1
QUIT
+22 IF GIEN=""
IF ATAGN'=""
SET GIEN=$ORDER(^BQI(90506.2,ATAGN,6,"B",STVCD,""))
+23 IF GIEN'=""
Begin DoDot:1
+24 ;Set HEADR
+25 SET DIS=$PIECE(^BQI(90506.2,ATAGN,6,GIEN,0),U,5)
+26 IF $PIECE(^BQI(90506.2,ATAGN,6,GIEN,0),U,9)=1
SET IFL=1
QUIT
+27 SET BQDTFRM=$PIECE(^BQI(90506.2,ATAGN,6,GIEN,0),U,8)
IF BQDTFRM=""
SET BQDTFRM="S"
+28 ;Get Value
+29 SET VAL=""
SET RES=""
+30 IF DFN'=""
SET RES=$$FTAG^BQICMUTL(ATAGN,GIEN,DFN)
+31 ;I 'RES S HDR="T00020"_STVCD,VAL="" Q
+32 IF DIS="D"
Begin DoDot:2
+33 SET HDR="T00020"_STVCD
+34 SET VAL=$SELECT(BQDTFRM="S":$$FMTE^BQIUL1($PIECE(RES,U,2)),1:$$FMTMDY^BQIUL1($PIECE(RES,U,2)))
End DoDot:2
+35 IF DIS="R"
SET HDR="T00025"_STVCD
SET VAL=$PIECE(RES,U,3)
+36 IF DIS="B"
Begin DoDot:2
+37 SET HDR="T00025"_STVCD
+38 SET VAL=$SELECT(BQDTFRM="S":$$FMTE^BQIUL1($PIECE(RES,U,2)),1:$$FMTMDY^BQIUL1($PIECE(RES,U,2)))_" "_$PIECE(RES,U,3)
End DoDot:2
+39 IF VAL'=""
IF $PIECE(RES,U,7)="refusal"
SET VAL="Refused "_VAL
End DoDot:1
QUIT
+40 QUIT
