BQIRGPL.m

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