Routine: BQIRGPT

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

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)

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")

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)

FND(SBFIL,SBFLD) ;

 NEW PTEXEC

 S PTEXEC=$$GET1^DIQ(90507,SREG_",",3,"E") I PTEXEC="" Q

 X PTEXEC

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

BQIRGPT.m