BQIMTCRD ;GDIT/HS/ALA-Get Definition Detail Data ; 04 Mar 2013 9:44 AM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
Q
;
EN(DATA,OWNR,PLIEN,CARE,PLIST) ;EP -- BQI GET MATCH CRITERIA DATA
;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,CODE,CRIEN,QFL
NEW CRN,CTYP,DOR,I,IFL,MTYP,NFLG,OCDT,PAT,RES,RESULT,RXIEN,RXN,STVCD,TYP,VISIT,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
;S @DATA@(II)="I00010RESULT^T00030MSG"_$C(30)
;,@DATA@(1)="-1^No Data Available"_$C(30),NFLG=1
I $L(CARE)=2 D I CRN="" Q
. S CRN=$O(^BQI(90506.5,"C",CARE,"")) I CRN="" Q
. S TYP=CARE,CARE=$P(^BQI(90506.5,CRN,0),U,1)
I $L(CARE)>2 D I CRN="" Q
. 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,MTYP=$P(^(0),U,17)
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
I CTYP="VS" S MTYP="VISIT"
I MTYP="" Q
;S MTYP=$S(CTYP="PR":"PROB",CTYP="ME":"MED",CTYP="LA":"LAB",CTYP="IN":"INP",CTYP="CP":"CPT",CTYP="ER":"ERV",CTYP="AL":"ALGY",CTYP="ED":"EDUC",CTYP="RE":"REM",CTYP="VS":"VISIT",1:"") I MTYP="" Q
S CRIEN=CRN
; 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,$G(@DATA@(II))="" D
. D HDR^BQIHEADR(OWNR,PLIEN,DFN,.BHEADR,.BVALUE)
. S HEADR=$$TKO^BQIUL1(BHEADR,"^"),@DATA@(II)=HEADR_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
PAT(DATA,OWNR,PLIEN,CARE,DFN) ;EP - Build record by patient
NEW MC,RIEN,VALUE,HEADR,CIEN,CDA,EXEC,DIS
I $G(DFN)="" Q
I DFN'="" D
. S MC=$O(^BQICARE(OWNR,1,PLIEN,40,DFN,5,"B",MTYP,"")) I MC="" Q
. S RIEN="",NFLG=0
. F S RIEN=$O(^BQICARE(OWNR,1,PLIEN,40,DFN,5,MC,1,"B",RIEN)) Q:RIEN="" D STND
Q
;
STND ; Get standard display
NEW IEN,HDR,VALUE,HEADR,SENS,HDOB,Y,STVW,TEXT,ORD,GMET,GHDR,RGIEN
NEW GIEN,CIEN,ATAGN,ATAGNM,ATAGST,TYP,DIS,REMDESC
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 CTYP="RE" S HEADR=HEADR_"T00010HIDE_REMCODE^T00015HIDE_REMMETH^"
;
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 CTYP="RE" D
. S PRN=$O(^BQICARE(OWNR,1,PLIEN,15,"B","REMCODE",""))
. S REMCODE=$P(^BQICARE(OWNR,1,PLIEN,15,PRN,0),U,2),REMDESC=$$VAL^BQIRMDR1(REMCODE)
. S VALUE=VALUE_REMCODE_$C(29)_REMDESC_U_$$GET1^DIQ(9000001,DFN_",",4002,"E")_U
;
; Find IEN
S IEN=""
F S IEN=$O(^BQI(90506.1,"AC",CTYP,IEN)) Q:IEN="" D
. I $P(^BQI(90506.1,IEN,0),U,6)'=".001" Q
. S HEADR=HEADR_$P(^BQI(90506.1,IEN,0),U,8)_U
. S STVW=IEN
. 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
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 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'="" 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 IEN=0
.. I $O(^BQICARE(OWNR,1,PLIEN,23,CIEN,1,IEN))="" D DEF Q
.. F S IEN=$O(^BQICARE(OWNR,1,PLIEN,23,CIEN,1,IEN)) Q:'IEN D
... S CODE=$P(^BQICARE(OWNR,1,PLIEN,23,CIEN,1,IEN,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 IEN=0
.. I $O(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,CIEN,1,IEN))="" D DEF Q
.. F S IEN=$O(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,CIEN,1,IEN)) Q:'IEN D
... S CODE=$P(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,CIEN,1,IEN,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 GIEN="" 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'="" D
. I CARE'="Lab Tests",$P($G(@DATA@(II)),$C(30),1)'=VALUE S II=II+1,@DATA@(II)=VALUE_$C(30) Q
. I CARE="Lab Tests" 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 MVALUE=MVALUE_$$TKO^BQIUL1(VAL,$C(10))
.. 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,IEN,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 IEN=""
. F S IEN=$O(^BQI(90506.1,"AF",TYP,ORD,IEN)) Q:IEN="" D
.. I $$GET1^DIQ(90506.1,IEN_",",.1,"I")=1 Q
.. S KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
.. I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
.. I $$GET1^DIQ(90506.1,IEN_",",3.04,"I")'="O" D
... S CODE=$P(^BQI(90506.1,IEN,0),U,1) Q:CODE=""
... I $P($G(^BQI(90506.1,IEN,0)),U,10)=1 Q
... S STVW=IEN
... 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 IEN=""
. F S IEN=$O(^BQI(90506.1,"AD",TYP,ORD,IEN)) Q:IEN="" D
.. I $$GET1^DIQ(90506.1,IEN_",",.1,"I")=1 Q
.. S KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
.. I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
.. I $$GET1^DIQ(90506.1,IEN_",",3.04,"I")'="O" D
... S CODE=$P(^BQI(90506.1,IEN,0),U,1) Q:CODE=""
... I $P($G(^BQI(90506.1,IEN,0)),U,10)=1 Q
... S STVW=IEN
... D CVAL
... S VALUE=VALUE_VAL_"^"
... S HEADR=HEADR_HDR_"^"
;
NEW CRIEN,TYP,ORD,IEN,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 IEN=""
. F S IEN=$O(^BQI(90506.1,"AD",TYP,ORD,IEN)) Q:IEN="" D
.. I $$GET1^DIQ(90506.1,IEN_",",.1,"I")=1 Q
.. S KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
.. I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
.. I $$GET1^DIQ(90506.1,IEN_",",3.04,"I")'="O" D
... S CODE=$P(^BQI(90506.1,IEN,0),U,1) Q:CODE=""
... I $P($G(^BQI(90506.1,IEN,0)),U,10)=1 Q
... S STVW=IEN
... 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
;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 RES=$$FND^BQICMUTL(CRN,GIEN,DFN)
. ;I 'RES S HDR="T00025"_STVCD,VAL="" Q
. I DIS="" S HDR="T00025"_STVCD,VAL=$P(RES,U,2)
. I DIS="D" D
.. S HDR="D00030"_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)))_" "_$P(RES,U,3)
. 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 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
;
SYM(RIEN) ;EP - Signs and symptoms
NEW GN
S RESULT=""
S GN=0
F S GN=$O(^GMR(120.8,RIEN,10,GN)) Q:'GN D
. NEW DA,IENS
. S DA(1)=RIEN,DA=GN,IENS=$$IENS^DILF(.DA)
. S RESULT=RESULT_$$GET1^DIQ(120.81,IENS,.01,"E")_"; "
S RESULT=1_U_$$TKO^BQIUL1(RESULT,"; ")
Q
;
LPR(DFN) ;Last time problem list reviewed for patient
NEW APCLBD,APCLED,APCLFORM
S APCLBD=$$DATE^BQIUL1("T-12M"),APCLED=DT,APCLFORM="D"
S RESULT=$$LASTPLR^APCLAPI6(DFN,APCLBD,APCLED,APCLFORM)
Q
;
LAC(DFN) ;last time no active problems for patient
NEW APCLBD,APCLED,APCLFORM
S APCLBD=$$DATE^BQIUL1("T-12M"),APCLED=DT,APCLFORM="D"
S RESULT=$$LASTNAP^APCLAPI6(DFN,APCLBD,APCLED,APCLFORM)
Q
BQIMTCRD ;GDIT/HS/ALA-Get Definition Detail Data ; 04 Mar 2013 9:44 AM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
+3 QUIT
+4 ;
EN(DATA,OWNR,PLIEN,CARE,PLIST) ;EP -- BQI GET MATCH CRITERIA DATA
+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,CODE,CRIEN,QFL
+9 NEW CRN,CTYP,DOR,I,IFL,MTYP,NFLG,OCDT,PAT,RES,RESULT,RXIEN,RXN,STVCD,TYP,VISIT,TQFL
+10 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+11 SET DATA=$NAME(^TMP("BQIRGPL",UID))
+12 KILL @DATA
+13 ;
+14 SET II=0
+15 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRGPL D UNWIND^%ZTER"
+16 ;S @DATA@(II)="I00010RESULT^T00030MSG"_$C(30)
+17 ;,@DATA@(1)="-1^No Data Available"_$C(30),NFLG=1
+18 IF $LENGTH(CARE)=2
Begin DoDot:1
+19 SET CRN=$ORDER(^BQI(90506.5,"C",CARE,""))
IF CRN=""
QUIT
+20 SET TYP=CARE
SET CARE=$PIECE(^BQI(90506.5,CRN,0),U,1)
End DoDot:1
IF CRN=""
QUIT
+21 IF $LENGTH(CARE)>2
Begin DoDot:1
+22 IF CARE'?.N
SET CRN=$ORDER(^BQI(90506.5,"B",CARE,""))
IF CRN=""
QUIT
End DoDot:1
IF CRN=""
QUIT
+23 IF CRN'=""
SET TYP=$PIECE(^BQI(90506.5,CRN,0),U,2)
SET CTYP=TYP
SET MTYP=$PIECE(^(0),U,17)
+24 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
+25 IF CTYP="VS"
SET MTYP="VISIT"
+26 IF MTYP=""
QUIT
+27 ;S MTYP=$S(CTYP="PR":"PROB",CTYP="ME":"MED",CTYP="LA":"LAB",CTYP="IN":"INP",CTYP="CP":"CPT",CTYP="ER":"ERV",CTYP="AL":"ALGY",CTYP="ED":"EDUC",CTYP="RE":"REM",CTYP="VS":"VISIT",1:"") I MTYP="" Q
+28 SET CRIEN=CRN
+29 ; If a list of DFNs, process them instead of entire panel
+30 IF $DATA(PLIST)>0
Begin DoDot:1
+31 IF $DATA(PLIST)>1
Begin DoDot:2
+32 SET LIST=""
SET BN=""
+33 FOR
SET BN=$ORDER(PLIST(BN))
IF BN=""
QUIT
SET LIST=LIST_PLIST(BN)
+34 KILL PLIST
SET PLIST=LIST
End DoDot:2
+35 FOR BQI=1:1
SET DFN=$PIECE(PLIST,$CHAR(28),BQI)
IF DFN=""
QUIT
Begin DoDot:2
+36 IF $PIECE($GET(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R"
QUIT
+37 DO PAT(.DATA,OWNR,PLIEN,CARE,DFN)
End DoDot:2
End DoDot:1
GOTO DONE
+38 ;
+39 SET DFN=0
+40 IF $ORDER(^BQICARE(OWNR,1,PLIEN,40,DFN))=""
DO PAT(.DATA,OWNR,PLIEN,CARE,"")
GOTO DONE
+41 ;
+42 FOR
SET DFN=$ORDER(^BQICARE(OWNR,1,PLIEN,40,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+43 IF $PIECE($GET(^BQICARE(OWNR,1,PLIEN,40,DFN,0)),"^",2)="R"
QUIT
+44 DO PAT(.DATA,OWNR,PLIEN,CARE,DFN)
End DoDot:1
+45 ;
DONE ;
+1 IF II=0
IF $GET(@DATA@(II))=""
Begin DoDot:1
+2 DO HDR^BQIHEADR(OWNR,PLIEN,DFN,.BHEADR,.BVALUE)
+3 SET HEADR=$$TKO^BQIUL1(BHEADR,"^")
SET @DATA@(II)=HEADR_$CHAR(30)
End DoDot:1
+4 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+5 QUIT
+6 ;
PAT(DATA,OWNR,PLIEN,CARE,DFN) ;EP - Build record by patient
+1 NEW MC,RIEN,VALUE,HEADR,CIEN,CDA,EXEC,DIS
+2 IF $GET(DFN)=""
QUIT
+3 IF DFN'=""
Begin DoDot:1
+4 SET MC=$ORDER(^BQICARE(OWNR,1,PLIEN,40,DFN,5,"B",MTYP,""))
IF MC=""
QUIT
+5 SET RIEN=""
SET NFLG=0
+6 FOR
SET RIEN=$ORDER(^BQICARE(OWNR,1,PLIEN,40,DFN,5,MC,1,"B",RIEN))
IF RIEN=""
QUIT
DO STND
End DoDot:1
+7 QUIT
+8 ;
STND ; Get standard display
+1 NEW IEN,HDR,VALUE,HEADR,SENS,HDOB,Y,STVW,TEXT,ORD,GMET,GHDR,RGIEN
+2 NEW GIEN,CIEN,ATAGN,ATAGNM,ATAGST,TYP,DIS,REMDESC
+3 SET VALUE=""
SET RGIEN=""
+4 IF DFN'=""
SET Y=$$GET1^DIQ(9000001,DFN_",",1102.2,"I")
SET HDOB=$$FMTE^BQIUL1(Y)
+5 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
+6 SET HEADR="I00010DFN^T00001TICKLER_INDICATOR^T00001FLAG_INDICATOR^T00001SENS_FLAG^T00001COMM_FLAG^T00001HIDE_MANUAL^D00030HIDE_DOB^"
+7 SET HEADR=HEADR_"I00010HIDE_ASSOC_TAG_IEN^T00030HIDE_ASSOC_TAG_NAME^T00001HIDE_ASSOC_TAG_STATUS^"
+8 IF CTYP="RE"
SET HEADR=HEADR_"T00010HIDE_REMCODE^T00015HIDE_REMMETH^"
+9 ;
+10 SET RGIEN=$PIECE(^BQI(90506.5,CRN,0),U,3)
IF RGIEN'=""
SET REG=$PIECE(^BQI(90507,RGIEN,0),U,1)
+11 SET ATAGN=$PIECE(^BQI(90506.5,CRN,0),U,11)
SET ATAGST=""
+12 IF ATAGN=""
SET ATAGNM="{None}"
SET ATAGST=""
+13 IF ATAGN'=""
SET ATAGNM=$PIECE(^BQI(90506.2,ATAGN,0),U,1)
+14 IF DFN'=""
SET ATAGST=$$CTAG^BQITDUTL(DFN,ATAGNM)
+15 IF ATAGST=""
SET ATAGN=""
SET ATAGNM="{None}"
+16 SET VALUE=VALUE_ATAGN_U_ATAGNM_U_ATAGST_U
+17 IF CTYP="RE"
Begin DoDot:1
+18 SET PRN=$ORDER(^BQICARE(OWNR,1,PLIEN,15,"B","REMCODE",""))
+19 SET REMCODE=$PIECE(^BQICARE(OWNR,1,PLIEN,15,PRN,0),U,2)
SET REMDESC=$$VAL^BQIRMDR1(REMCODE)
+20 SET VALUE=VALUE_REMCODE_$CHAR(29)_REMDESC_U_$$GET1^DIQ(9000001,DFN_",",4002,"E")_U
End DoDot:1
+21 ;
+22 ; Find IEN
+23 SET IEN=""
+24 FOR
SET IEN=$ORDER(^BQI(90506.1,"AC",CTYP,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+25 IF $PIECE(^BQI(90506.1,IEN,0),U,6)'=".001"
QUIT
+26 SET HEADR=HEADR_$PIECE(^BQI(90506.1,IEN,0),U,8)_U
+27 SET STVW=IEN
+28 ;New'd variable since it gets used in executable calls
NEW CRIEN
+29 XECUTE ^BQI(90506.1,STVW,1)
+30 SET VALUE=VALUE_VAL_U
End DoDot:1
+31 ;
+32 ; Check for template
+33 NEW DA,IENS,TEMPL,LYIEN,QFL
+34 SET TEMPL=""
+35 IF OWNR'=DUZ
Begin DoDot:1
+36 SET DA=$ORDER(^BQICARE(OWNR,1,PLIEN,30,DUZ,4,"C",CTYP,""))
+37 IF DA=""
QUIT
+38 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=DUZ
SET IENS=$$IENS^DILF(.DA)
+39 SET TEMPL=$$GET1^DIQ(90505.34,IENS,.01,"E")
End DoDot:1
+40 IF OWNR=DUZ
Begin DoDot:1
+41 SET DA=$ORDER(^BQICARE(OWNR,1,PLIEN,4,"C",CTYP,""))
+42 IF DA=""
QUIT
+43 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET IENS=$$IENS^DILF(.DA)
+44 SET TEMPL=$$GET1^DIQ(90505.14,IENS,.01,"E")
End DoDot:1
+45 ;
+46 ; If template, use it
+47 IF TEMPL'=""
SET TQFL=0
Begin DoDot:1
+48 ;S LYIEN=$$DEF^BQILYUTL(OWNR,"M")
+49 SET LYIEN=$$TPN^BQILYUTL(DUZ,TEMPL)
+50 IF LYIEN=""
SET TQFL=1
QUIT
+51 SET DOR=""
+52 FOR
SET DOR=$ORDER(^BQICARE(DUZ,15,LYIEN,1,"C",DOR))
IF DOR=""
QUIT
Begin DoDot:2
+53 SET IEN=""
+54 FOR
SET IEN=$ORDER(^BQICARE(DUZ,15,LYIEN,1,"C",DOR,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+55 SET CODE=$PIECE(^BQICARE(DUZ,15,LYIEN,1,IEN,0),U,1)
+56 SET GIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
+57 IF GIEN'=""
Begin DoDot:4
+58 SET STVW=GIEN
+59 IF $PIECE($GET(^BQI(90506.1,GIEN,0)),U,10)=1
QUIT
+60 DO CVAL
End DoDot:4
+61 IF GIEN=""
SET IFL=0
Begin DoDot:4
+62 SET STVCD=CODE
+63 DO CKO
End DoDot:4
IF IFL
QUIT
+64 SET VALUE=VALUE_VAL_"^"
+65 SET HEADR=HEADR_HDR_"^"
End DoDot:3
End DoDot:2
End DoDot:1
IF 'TQFL
GOTO FIN
+66 ;
+67 ; If no template, check for customized
+68 IF OWNR=DUZ
Begin DoDot:1
+69 SET CIEN=$ORDER(^BQICARE(OWNR,1,PLIEN,23,"B",CARE,""))
+70 IF CIEN'=""
Begin DoDot:2
+71 SET IEN=0
+72 IF $ORDER(^BQICARE(OWNR,1,PLIEN,23,CIEN,1,IEN))=""
DO DEF
QUIT
+73 FOR
SET IEN=$ORDER(^BQICARE(OWNR,1,PLIEN,23,CIEN,1,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+74 SET CODE=$PIECE(^BQICARE(OWNR,1,PLIEN,23,CIEN,1,IEN,0),"^",1)
IF CODE=""
QUIT
+75 SET GIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
+76 IF GIEN'=""
Begin DoDot:4
+77 SET STVW=GIEN
+78 IF $PIECE($GET(^BQI(90506.1,GIEN,0)),U,10)=1
QUIT
+79 DO CVAL
End DoDot:4
+80 IF GIEN=""
SET IFL=0
Begin DoDot:4
+81 SET STVCD=CODE
+82 DO CKO
End DoDot:4
IF IFL
QUIT
+83 SET VALUE=VALUE_VAL_"^"
+84 SET HEADR=HEADR_HDR_"^"
End DoDot:3
End DoDot:2
+85 ;
+86 ; If no customized, use default
+87 IF CIEN=""
DO DEF
End DoDot:1
+88 ;
+89 IF OWNR'=DUZ
Begin DoDot:1
+90 SET CIEN=$ORDER(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,"B",CARE,""))
+91 IF CIEN'=""
Begin DoDot:2
+92 SET IEN=0
+93 IF $ORDER(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,CIEN,1,IEN))=""
DO DEF
QUIT
+94 FOR
SET IEN=$ORDER(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,CIEN,1,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+95 SET CODE=$PIECE(^BQICARE(OWNR,1,PLIEN,30,DUZ,23,CIEN,1,IEN,0),"^",1)
IF CODE=""
QUIT
+96 SET GIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
+97 IF GIEN'=""
Begin DoDot:4
+98 SET STVW=GIEN
+99 IF $PIECE($GET(^BQI(90506.1,GIEN,0)),U,10)=1
QUIT
+100 KILL VAL
+101 DO CVAL
End DoDot:4
+102 IF GIEN=""
SET IFL=0
Begin DoDot:4
+103 SET STVCD=CODE
+104 DO CKO
End DoDot:4
IF IFL
QUIT
+105 SET HEADR=HEADR_HDR_"^"
+106 ;I VALUE=$$TKO^BQIUL1(VAL,";") Q
+107 ;I VALUE=$P(VAL,";"),$P(VAL,";",2)'="" S VALUE=VALUE_$P(VAL,";",2)_"^" Q
+108 SET VALUE=VALUE_VAL_"^"
End DoDot:3
End DoDot:2
+109 IF CIEN=""
DO DEF
End DoDot:1
+110 ;
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'=""
Begin DoDot:1
+8 IF CARE'="Lab Tests"
IF $PIECE($GET(@DATA@(II)),$CHAR(30),1)'=VALUE
SET II=II+1
SET @DATA@(II)=VALUE_$CHAR(30)
QUIT
+9 IF CARE="Lab Tests"
SET II=II+1
SET @DATA@(II)=VALUE_$CHAR(30)
End DoDot:1
+10 QUIT
+11 ;
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:"")
End DoDot:4
+46 SET MVALUE=MVALUE_$$TKO^BQIUL1(VAL,$CHAR(10))
End DoDot:3
+47 SET VAL=MVALUE
End DoDot:2
QUIT
End DoDot:1
IF VAL'=""
QUIT
+48 ;
+49 IF FIL'=""
IF FLD'=""
SET VAL=$$GET1^DIQ(FIL,DFN_",",FLD,"E")
+50 QUIT
+51 ;
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,IEN,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 IEN=""
+8 FOR
SET IEN=$ORDER(^BQI(90506.1,"AF",TYP,ORD,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+9 IF $$GET1^DIQ(90506.1,IEN_",",.1,"I")=1
QUIT
+10 SET KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
+11 IF KEY'=""
IF '$$KEYCHK^BQIULSC(KEY,DUZ)
QUIT
+12 IF $$GET1^DIQ(90506.1,IEN_",",3.04,"I")'="O"
Begin DoDot:3
+13 SET CODE=$PIECE(^BQI(90506.1,IEN,0),U,1)
IF CODE=""
QUIT
+14 IF $PIECE($GET(^BQI(90506.1,IEN,0)),U,10)=1
QUIT
+15 SET STVW=IEN
+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 IEN=""
+25 FOR
SET IEN=$ORDER(^BQI(90506.1,"AD",TYP,ORD,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+26 IF $$GET1^DIQ(90506.1,IEN_",",.1,"I")=1
QUIT
+27 SET KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
+28 IF KEY'=""
IF '$$KEYCHK^BQIULSC(KEY,DUZ)
QUIT
+29 IF $$GET1^DIQ(90506.1,IEN_",",3.04,"I")'="O"
Begin DoDot:3
+30 SET CODE=$PIECE(^BQI(90506.1,IEN,0),U,1)
IF CODE=""
QUIT
+31 IF $PIECE($GET(^BQI(90506.1,IEN,0)),U,10)=1
QUIT
+32 SET STVW=IEN
+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,IEN,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 IEN=""
+43 FOR
SET IEN=$ORDER(^BQI(90506.1,"AD",TYP,ORD,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+44 IF $$GET1^DIQ(90506.1,IEN_",",.1,"I")=1
QUIT
+45 SET KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
+46 IF KEY'=""
IF '$$KEYCHK^BQIULSC(KEY,DUZ)
QUIT
+47 IF $$GET1^DIQ(90506.1,IEN_",",3.04,"I")'="O"
Begin DoDot:3
+48 SET CODE=$PIECE(^BQI(90506.1,IEN,0),U,1)
IF CODE=""
QUIT
+49 IF $PIECE($GET(^BQI(90506.1,IEN,0)),U,10)=1
QUIT
+50 SET STVW=IEN
+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
+62 DO CKO
+63 SET VALUE=VALUE_VAL_"^"
+64 SET HEADR=HEADR_HDR_"^"
End DoDot:2
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
+73 DO CKO
+74 SET VALUE=VALUE_VAL_"^"
+75 SET HEADR=HEADR_HDR_"^"
End DoDot:3
End DoDot:2
End DoDot:1
+76 QUIT
+77 ;
CKO ; Check other
+1 NEW BQDTFRM
+2 ;I $P(STVCD,"_",1)'=CTYP Q
+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 RES=$$FND^BQICMUTL(CRN,GIEN,DFN)
+11 ;I 'RES S HDR="T00025"_STVCD,VAL="" Q
+12 IF DIS=""
SET HDR="T00025"_STVCD
SET VAL=$PIECE(RES,U,2)
+13 IF DIS="D"
Begin DoDot:2
+14 SET HDR="D00030"_STVCD
+15 SET VAL=$SELECT(BQDTFRM="S":$$FMTE^BQIUL1($PIECE(RES,U,2)),1:$$FMTMDY^BQIUL1($PIECE(RES,U,2)))
End DoDot:2
+16 IF DIS="R"
SET HDR="T00025"_STVCD
SET VAL=$PIECE(RES,U,2)
+17 IF DIS="B"
Begin DoDot:2
+18 SET HDR="T00025"_STVCD
+19 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
+20 IF VAL'=""
IF $PIECE(RES,U,7)="refusal"
SET VAL="Refused "_VAL
End DoDot:1
QUIT
+21 IF GIEN=""
IF ATAGN'=""
SET GIEN=$ORDER(^BQI(90506.2,ATAGN,6,"B",STVCD,""))
+22 IF GIEN'=""
Begin DoDot:1
+23 ;Set HEADR
+24 SET DIS=$PIECE(^BQI(90506.2,ATAGN,6,GIEN,0),U,5)
+25 IF $PIECE(^BQI(90506.2,ATAGN,6,GIEN,0),U,9)=1
SET IFL=1
QUIT
+26 SET BQDTFRM=$PIECE(^BQI(90506.2,ATAGN,6,GIEN,0),U,8)
IF BQDTFRM=""
SET BQDTFRM="S"
+27 ;Get Value
+28 SET RES=$$FTAG^BQICMUTL(ATAGN,GIEN,DFN)
+29 ;I 'RES S HDR="T00020"_STVCD,VAL="" Q
+30 IF DIS="D"
Begin DoDot:2
+31 SET HDR="T00020"_STVCD
+32 SET VAL=$SELECT(BQDTFRM="S":$$FMTE^BQIUL1($PIECE(RES,U,2)),1:$$FMTMDY^BQIUL1($PIECE(RES,U,2)))
End DoDot:2
+33 IF DIS="R"
SET HDR="T00025"_STVCD
SET VAL=$PIECE(RES,U,3)
+34 IF DIS="B"
Begin DoDot:2
+35 SET HDR="T00025"_STVCD
+36 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
+37 IF VAL'=""
IF $PIECE(RES,U,7)="refusal"
SET VAL="Refused "_VAL
End DoDot:1
QUIT
+38 QUIT
+39 ;
SYM(RIEN) ;EP - Signs and symptoms
+1 NEW GN
+2 SET RESULT=""
+3 SET GN=0
+4 FOR
SET GN=$ORDER(^GMR(120.8,RIEN,10,GN))
IF 'GN
QUIT
Begin DoDot:1
+5 NEW DA,IENS
+6 SET DA(1)=RIEN
SET DA=GN
SET IENS=$$IENS^DILF(.DA)
+7 SET RESULT=RESULT_$$GET1^DIQ(120.81,IENS,.01,"E")_"; "
End DoDot:1
+8 SET RESULT=1_U_$$TKO^BQIUL1(RESULT,"; ")
+9 QUIT
+10 ;
LPR(DFN) ;Last time problem list reviewed for patient
+1 NEW APCLBD,APCLED,APCLFORM
+2 SET APCLBD=$$DATE^BQIUL1("T-12M")
SET APCLED=DT
SET APCLFORM="D"
+3 SET RESULT=$$LASTPLR^APCLAPI6(DFN,APCLBD,APCLED,APCLFORM)
+4 QUIT
+5 ;
LAC(DFN) ;last time no active problems for patient
+1 NEW APCLBD,APCLED,APCLFORM
+2 SET APCLBD=$$DATE^BQIUL1("T-12M")
SET APCLED=DT
SET APCLFORM="D"
+3 SET RESULT=$$LASTNAP^APCLAPI6(DFN,APCLBD,APCLED,APCLFORM)
+4 QUIT
