BQIRGPT ;PRXM/HC/ALA-Get register data by patient ; 05 Nov 2007 12:19 PM
;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
;
Q
;
EN(DATA,DFN,REG) ;EP -- BQI GET REG DATA BY PATIENT
;Input parameter
; DFN - Patient internal entry number
; REG - Register name
;
NEW UID,II
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRGPT",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRGPT D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;Build record by patient
NEW IEN,HDR,VALUE,HEADR,SENS,HDOB,Y,STVW,TEXT,ORD,HDIEN,SUB,SREG,RIENS,RGIEN
NEW CODE,TYPE,BI,IENS,RIEN,SEXEC,SFIL,SFLD,VAL
;
S RGIEN=$O(^BQI(90506.3,"B",REG,""))
I RGIEN="" S @DATA@(II)="T00030IEN"_$C(30) G DONE
;
; Check if this is a sub-definition
;
S SUB=+$P(^BQI(90506.3,RGIEN,0),U,7)
;
S SREG=$O(^BQI(90507,"B",REG,""))
NEW PTEXEC
S PTEXEC=$$GET1^DIQ(90507,SREG_",",3,"E")
I PTEXEC'="" X PTEXEC S RIENS=IENS
;
; if not a subdefinition, define the record internal entry number
S HDIEN=$O(^BQI(90506.3,RGIEN,10,"AE","Y",""))
S HEADR=$S(HDIEN'="":$P(^BQI(90506.3,RGIEN,10,HDIEN,0),U,2),1:"T00030IEN")_"^"
S VALUE=$G(RIENS)_U
;
S ORD="" K DISPLAY
F S ORD=$O(^BQI(90506.3,RGIEN,10,"C",ORD)) Q:ORD="" D
. S RIEN=""
. F S RIEN=$O(^BQI(90506.3,RGIEN,10,"C",ORD,RIEN)) Q:RIEN="" D
.. ;I $P(^BQI(90506.3,RGIEN,10,RIEN,0),U,4)'="S" Q
.. S CODE=$P(^BQI(90506.3,RGIEN,10,RIEN,0),U,7) I CODE="" Q
.. S TYPE=$P($G(^BQI(90506.3,RGIEN,10,RIEN,1)),U,1)
.. S IEN=$O(^BQI(90506.1,"B",CODE,"")) I IEN="" Q
.. I $$GET1^DIQ(90506.1,IEN_",",.1,"I")=1 Q
.. I $$GET1^DIQ(90506.1,IEN_",",3.07,"I")=1 Q
.. S KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
.. I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
.. S STVW=$P(^BQI(90506.1,IEN,0),U,1)
.. S HDR=$$GET1^DIQ(90506.1,IEN_",",.08,"E")
.. I SUB S DISPLAY(ORD)=HDR_"^"_$$GET1^DIQ(90506.1,IEN_",",.06,"E")_"^"_TYPE Q
.. S STVW=IEN D CVAL
.. S VALUE=VALUE_VAL_"^"
.. S HEADR=HEADR_HDR_"^"
;
I SUB D
. S SREG=$P(^BQI(90506.3,RGIEN,0),U,8)
. S SFIL=$P(^BQI(90506.3,RGIEN,0),U,10)
. S SFLD=$P(^BQI(90506.3,RGIEN,0),U,11)
. S SEXEC=$G(^BQI(90506.3,RGIEN,1))
. I SEXEC'="" X SEXEC
. ;D EN^BQIRGHML(.HEADR,.VALUE,DFN,SFIL,SFLD,.DISPLAY)
;
S HEADR=$$TKO^BQIUL1(HEADR,"^")
;
S @DATA@(II)=HEADR_$C(30)
I $D(VALUE)=1,$G(VALUE)="" G DONE
I $D(VALUE)<11 D
. S VALUE=$$TKO^BQIUL1(VALUE,"^")
. S II=II+1,@DATA@(II)=VALUE_$C(30)
I $D(VALUE)>1 D
. S BI=""
. F S BI=$O(VALUE(BI)) Q:BI="" D
.. S VALUE=VALUE(BI)
.. S VALUE=$$TKO^BQIUL1(VALUE,"^")
.. S II=II+1,@DATA@(II)=VALUE_$C(30)
;
K VALUE
;
DONE S II=II+1,@DATA@(II)=$C(31)
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=$$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=$$GET1^DIQ(90506.1,STVW_",",.08,"E")
I $G(DFN)="" S VAL="" Q
;
I $G(EXEC)'="" X EXEC Q
;
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
;
FND(SBFIL,SBFLD) ;
NEW PTEXEC
S PTEXEC=$$GET1^DIQ(90507,SREG_",",3,"E") I PTEXEC="" Q
X PTEXEC
;
Q
BQIRGPT ;PRXM/HC/ALA-Get register data by patient ; 05 Nov 2007 12:19 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
+2 ;
+3 QUIT
+4 ;
EN(DATA,DFN,REG) ;EP -- BQI GET REG DATA BY PATIENT
+1 ;Input parameter
+2 ; DFN - Patient internal entry number
+3 ; REG - Register name
+4 ;
+5 NEW UID,II
+6 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+7 SET DATA=$NAME(^TMP("BQIRGPT",UID))
+8 KILL @DATA
+9 ;
+10 SET II=0
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRGPT D UNWIND^%ZTER"
+12 ;Build record by patient
+13 NEW IEN,HDR,VALUE,HEADR,SENS,HDOB,Y,STVW,TEXT,ORD,HDIEN,SUB,SREG,RIENS,RGIEN
+14 NEW CODE,TYPE,BI,IENS,RIEN,SEXEC,SFIL,SFLD,VAL
+15 ;
+16 SET RGIEN=$ORDER(^BQI(90506.3,"B",REG,""))
+17 IF RGIEN=""
SET @DATA@(II)="T00030IEN"_$CHAR(30)
GOTO DONE
+18 ;
+19 ; Check if this is a sub-definition
+20 ;
+21 SET SUB=+$PIECE(^BQI(90506.3,RGIEN,0),U,7)
+22 ;
+23 SET SREG=$ORDER(^BQI(90507,"B",REG,""))
+24 NEW PTEXEC
+25 SET PTEXEC=$$GET1^DIQ(90507,SREG_",",3,"E")
+26 IF PTEXEC'=""
XECUTE PTEXEC
SET RIENS=IENS
+27 ;
+28 ; if not a subdefinition, define the record internal entry number
+29 SET HDIEN=$ORDER(^BQI(90506.3,RGIEN,10,"AE","Y",""))
+30 SET HEADR=$SELECT(HDIEN'="":$PIECE(^BQI(90506.3,RGIEN,10,HDIEN,0),U,2),1:"T00030IEN")_"^"
+31 SET VALUE=$GET(RIENS)_U
+32 ;
+33 SET ORD=""
KILL DISPLAY
+34 FOR
SET ORD=$ORDER(^BQI(90506.3,RGIEN,10,"C",ORD))
IF ORD=""
QUIT
Begin DoDot:1
+35 SET RIEN=""
+36 FOR
SET RIEN=$ORDER(^BQI(90506.3,RGIEN,10,"C",ORD,RIEN))
IF RIEN=""
QUIT
Begin DoDot:2
+37 ;I $P(^BQI(90506.3,RGIEN,10,RIEN,0),U,4)'="S" Q
+38 SET CODE=$PIECE(^BQI(90506.3,RGIEN,10,RIEN,0),U,7)
IF CODE=""
QUIT
+39 SET TYPE=$PIECE($GET(^BQI(90506.3,RGIEN,10,RIEN,1)),U,1)
+40 SET IEN=$ORDER(^BQI(90506.1,"B",CODE,""))
IF IEN=""
QUIT
+41 IF $$GET1^DIQ(90506.1,IEN_",",.1,"I")=1
QUIT
+42 IF $$GET1^DIQ(90506.1,IEN_",",3.07,"I")=1
QUIT
+43 SET KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
+44 IF KEY'=""
IF '$$KEYCHK^BQIULSC(KEY,DUZ)
QUIT
+45 SET STVW=$PIECE(^BQI(90506.1,IEN,0),U,1)
+46 SET HDR=$$GET1^DIQ(90506.1,IEN_",",.08,"E")
+47 IF SUB
SET DISPLAY(ORD)=HDR_"^"_$$GET1^DIQ(90506.1,IEN_",",.06,"E")_"^"_TYPE
QUIT
+48 SET STVW=IEN
DO CVAL
+49 SET VALUE=VALUE_VAL_"^"
+50 SET HEADR=HEADR_HDR_"^"
End DoDot:2
End DoDot:1
+51 ;
+52 IF SUB
Begin DoDot:1
+53 SET SREG=$PIECE(^BQI(90506.3,RGIEN,0),U,8)
+54 SET SFIL=$PIECE(^BQI(90506.3,RGIEN,0),U,10)
+55 SET SFLD=$PIECE(^BQI(90506.3,RGIEN,0),U,11)
+56 SET SEXEC=$GET(^BQI(90506.3,RGIEN,1))
+57 IF SEXEC'=""
XECUTE SEXEC
+58 ;D EN^BQIRGHML(.HEADR,.VALUE,DFN,SFIL,SFLD,.DISPLAY)
End DoDot:1
+59 ;
+60 SET HEADR=$$TKO^BQIUL1(HEADR,"^")
+61 ;
+62 SET @DATA@(II)=HEADR_$CHAR(30)
+63 IF $DATA(VALUE)=1
IF $GET(VALUE)=""
GOTO DONE
+64 IF $DATA(VALUE)<11
Begin DoDot:1
+65 SET VALUE=$$TKO^BQIUL1(VALUE,"^")
+66 SET II=II+1
SET @DATA@(II)=VALUE_$CHAR(30)
End DoDot:1
+67 IF $DATA(VALUE)>1
Begin DoDot:1
+68 SET BI=""
+69 FOR
SET BI=$ORDER(VALUE(BI))
IF BI=""
QUIT
Begin DoDot:2
+70 SET VALUE=VALUE(BI)
+71 SET VALUE=$$TKO^BQIUL1(VALUE,"^")
+72 SET II=II+1
SET @DATA@(II)=VALUE_$CHAR(30)
End DoDot:2
End DoDot:1
+73 ;
+74 KILL VALUE
+75 ;
DONE SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
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=$$GET1^DIQ(90506.1,STVW_",",.05,"E")
+9 SET FLD=$$GET1^DIQ(90506.1,STVW_",",.06,"E")
+10 SET EXEC=$$GET1^DIQ(90506.1,STVW_",",1,"E")
+11 SET HDR=$$GET1^DIQ(90506.1,STVW_",",.08,"E")
+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 ;
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 ;
FND(SBFIL,SBFLD) ;
+1 NEW PTEXEC
+2 SET PTEXEC=$$GET1^DIQ(90507,SREG_",",3,"E")
IF PTEXEC=""
QUIT
+3 XECUTE PTEXEC
+4 ;
+5 QUIT
