Routine: BQIPTFHR

BQIPTFHR ;VNGT/HS/BEE-Family History Display ; 12 Sep 2008  12:30 PM

 ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41

EN(DATA,DFN) ; EP -- BQI GET FAM HIST DISPLAY

 ;Description - all the family history that a patient has

 ;Input Parameters

 ;  DFN - Patient internal entry number

 NEW ARRAY,UID,II,FAM,FHCIEN,FHRIEN,FHRREL,FHRDES,FHRSTS,FHRDTU,FHRMB,FHRMBT,FHRMBD,FHRAAD,FHRCOD,RORD,RELNM

 S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)

 S DATA=$NA(^TMP("BQIPTFHR",UID))

 K @DATA

 S II=0

 NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHR D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2

 I $$VERSION^XPDUTL("BJPC")<2.0 S BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS" Q

 ;Verify Patient DFN is populated

 I $G(DFN)="" S BMXSEC="Patient DFN is required" Q

 S @DATA@(II)="I00010FHCIEN^I00010FHRIEN^T00060FHRREL^T00030FHRDES^T00060FHCDX^T00080FHCNAR^"

 S @DATA@(II)=@DATA@(II)_"T00020FHCAAO^T00020FHRSTS^D00030FHCDTN^T00100APCDTNQ^T00050FHCPRV^"

 S @DATA@(II)=@DATA@(II)_"T00015FHRAAD^T00060FHRCOD^T00010FHRMB^T00020FHRMBT^T00030FHRMBD^D00015FHCDTM^D00030FHRDTU"_$C(30)

 S FHCIEN="" F  S FHCIEN=$O(^AUPNFH("AC",DFN,FHCIEN)) Q:FHCIEN=""  D

. ;

 . N APCDTNQ,BQICND,DIEN,FHCAAO,FHCDX,FHCDTM,FHCDTN,FHCNAR,FHCPRV,REIN

 . D GETS^DIQ(9000014,FHCIEN,"**","IE","BQICND")

. ;

 . ;Date Noted

 . S FHCDTN=$G(BQICND(9000014,FHCIEN_",",".03","I"))

. ;

 . ;DX Code (Condition)

 . S DIEN=$$GET1^DIQ(9000014,FHCIEN_",",.01,"I") ;Using $$GET1^DIQ as GETS^DIQ sometimes omits .01 entry

 . I DIEN="" Q

 . I $$VERSION^XPDUTL("BCSV") S FHCDX=$$ICD9^BQIUL3(DIEN,FHCDTN,2)_"-"_$$ICD9^BQIUL3(DIEN,FHCDTN,4) ; csv

 . I '$$VERSION^XPDUTL("BCSV") S FHCDX=$$GET1^DIQ(80,DIEN_",",.01,"E")_"-"_$$GET1^DIQ(80,DIEN_",",3,"E")

 . S FHCDX=DIEN_$C(28)_FHCDX S:$P(FHCDX,$C(28))="-" FHCDX=""

. ;

 . ;Diagnosis Narrative (Provider Narrative)

 . ;S FHCNAR=$G(BQICND(9000014,FHCIEN_",",".04","E"))

. ;

 . ;Narrative

 . NEW NIEN

 . S APCDTNQ=""

 . S NIEN=$G(BQICND(9000014,FHCIEN_",",".04","I"))

 . I $$PATCH^XPDUTL("BJPC*2.0*10") S FHCNAR=$$PNPROB^AUPNVUTL(NIEN)

 . E  S FHCNAR=$G(BQICND(9000014,FHCIEN_",",".04","E"))

 . S APCDTNQ=NIEN_$C(28)_FHCNAR

 . S:$P(APCDTNQ,$C(28))="" APCDTNQ=""

. ;

 . ;Age at Onset

 . S FHCAAO=$G(BQICND(9000014,FHCIEN_",",".11","I"))_$C(28)_$G(BQICND(9000014,FHCIEN_",",".11","E"))

 . S:$P(FHCAAO,$C(28))="" FHCAAO=""

. ;

 . ;Provider

 . S FHCPRV=$G(BQICND(9000014,FHCIEN_",",".08","I"))_$C(28)_$G(BQICND(9000014,FHCIEN_",",".08","E"))

 . S:$P(FHCPRV,$C(28))="" FHCPRV=""

. ;

 . ;Relation IEN

 . S FHRIEN=$G(BQICND(9000014,FHCIEN_",",".09","I"))

 . I FHRIEN'="" S FAM(FHRIEN)=""

. ;

 . ;Pull Relation Information - FHRREL, FHRDES, FHRSTS, FHRDTU, FHRMB, FHRMBT, FHRMBD, FHRAAD, FHRCOD

 . D GFAM(FHRIEN)

. ;

 . ;Date Last Modified

 . S FHCDTM=$G(BQICND(9000014,FHCIEN_",",".12","I"))

. ;

 . ;Set up sorting array

 . S ARRAY(RORD,RELNM,FHCIEN)=FHCIEN_U_FHRIEN_U_FHRREL_U_FHRDES_U_FHCDX_U_FHCNAR_U_FHCAAO_U_FHRSTS_U_$$FMTE^BQIUL1(FHCDTN)_U_APCDTNQ_U_FHCPRV_U_FHRAAD_U_FHRCOD_U_FHRMB_U_FHRMBT_U_FHRMBD_U_$$FMTE^BQIUL1(FHCDTM)_U_$$FMTE^BQIUL1(FHRDTU)_$C(30)

 S RIEN="" F  S RIEN=$O(^AUPNFHR("AA",DFN,RIEN)) Q:'RIEN  D

 . S FHRIEN="" F  S FHRIEN=$O(^AUPNFHR("AA",DFN,RIEN,FHRIEN)) Q:FHRIEN=""  D

 .. I $D(FAM(FHRIEN)) Q

 .. ;

 .. ; For family without diagnoses search FAMILY HISTORY FAMILY MEMBERS file

 .. D GFAM(FHRIEN)

 .. S ARRAY(RORD,RELNM,"R"_FHRIEN)=U_FHRIEN_U_FHRREL_U_FHRDES_U_U_U_U_FHRSTS_U_U_U_U_FHRAAD_U_FHRCOD_U_FHRMB_U_FHRMBT_U_FHRMBD_U_U_$$FMTE^BQIUL1(FHRDTU)_$C(30)

 ;Create record entries

 S RORD="" F  S RORD=$O(ARRAY(RORD)) Q:RORD=""  D

 . S RELNM="" F  S RELNM=$O(ARRAY(RORD,RELNM)) Q:RELNM=""  D

 .. S FHCIEN="" F  S FHCIEN=$O(ARRAY(RORD,RELNM,FHCIEN)) Q:FHCIEN=""  D

 ... S II=II+1,@DATA@(II)=ARRAY(RORD,RELNM,FHCIEN)

 S II=II+1,@DATA@(II)=$C(31)

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)

GFAM(FHRIEN) ; Get FAMILY HISTORY FAMILY MEMBERS Data

 N BQIREL,RIEN,RELT

 S (FHRREL,FHRDES,FHRSTS,FHRDTU,FHRMB,FHRMBT,FHRMBD,FHRAAD,FHRCOD)=""

 I FHRIEN="" S (RORD,RELNM)="~" Q

 D GETS^DIQ(9000014.1,FHRIEN,"**","IE","BQIREL")

 ;Relative (Relation) and Sort variables

 S REIN=$G(BQIREL(9000014.1,FHRIEN_",",".01","I"))

 S RELT=$G(BQIREL(9000014.1,FHRIEN_",",".01","E"))

 S RELNM=RELT S:RELNM="" RELNM="~"

 S FHRREL="" I REIN'="" S FHRREL=REIN_$C(28)_RELT

 S RORD=$$GET1^DIQ(9999999.36,REIN_",",2103,"E") S:RORD="" RORD="~"

 ;Relation Modifier (Description)

 S FHRDES=$G(BQIREL(9000014.1,FHRIEN_",",".03","E"))

 ;Status

 S FHRSTS=$G(BQIREL(9000014.1,FHRIEN_",",".04","I"))_$C(28)_$G(BQIREL(9000014.1,FHRIEN_",",".04","E"))

 S:$P(FHRSTS,$C(28))="" FHRSTS=""

 ;Date Updated

 S FHRDTU=$G(BQIREL(9000014.1,FHRIEN_",",".09","I"))

 ;Multiple Birth Status

 S FHRMB=$G(BQIREL(9000014.1,FHRIEN_",",".07","I"))_$C(28)_$G(BQIREL(9000014.1,FHRIEN_",",".07","E"))

 S FHRMBD=FHRMB

 S:$P(FHRMB,$C(28))="" FHRMB=""

 ;Multiple Birth Type

 S FHRMBT=$G(BQIREL(9000014.1,FHRIEN_",",".08","I"))_$C(28)_$G(BQIREL(9000014.1,FHRIEN_",",".08","E"))

 S FHRMBD=FHRMBD_$C(28)_FHRMBT

 S:$P(FHRMBT,$C(28))="" FHRMBT=""

 ;Multiple Birth Display

 I $TR(FHRMBD,$C(28))="" S FHRMBD=""

 ;Age at Death

 S FHRAAD=$G(BQIREL(9000014.1,FHRIEN_",",".05","I"))_$C(28)_$G(BQIREL(9000014.1,FHRIEN_",",".05","E"))

 S:$P(FHRAAD,$C(28))="" FHRAAD=""

 ;Cause of Death

 S FHRCOD=$G(BQIREL(9000014.1,FHRIEN_",",".06","E"))

BQIPTFHR  ;VNGT/HS/BEE-Family History Display ; 12 Sep 2008  12:30 PM

 +1       ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41

 +2       ;

 +3        QUIT

 +4       ;

EN(DATA,DFN) ; EP -- BQI GET FAM HIST DISPLAY

 +1       ;

 +2       ;Description - all the family history that a patient has

 +3       ;

 +4       ;Input Parameters

 +5       ;  DFN - Patient internal entry number

 +6       ;

 +7        NEW ARRAY,UID,II,FAM,FHCIEN,FHRIEN,FHRREL,FHRDES,FHRSTS,FHRDTU,FHRMB,FHRMBT,FHRMBD,FHRAAD,FHRCOD,RORD,RELNM

 +8       ;

 +9        SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)

 +10       SET DATA=$NAME(^TMP("BQIPTFHR",UID))

 +11       KILL @DATA

 +12      ;

 +13       SET II=0

 +14      ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

           SET $ETRAP="D ERR^BQIPTFHR D UNWIND^%ZTER"

 +15      ;

 +16       IF $$VERSION^XPDUTL("BJPC")<2.0

               SET BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS"

               QUIT

 +17      ;

 +18      ;Verify Patient DFN is populated

 +19       IF $GET(DFN)=""

               SET BMXSEC="Patient DFN is required"

               QUIT

 +20      ;

 +21       SET @DATA@(II)="I00010FHCIEN^I00010FHRIEN^T00060FHRREL^T00030FHRDES^T00060FHCDX^T00080FHCNAR^"

 +22       SET @DATA@(II)=@DATA@(II)_"T00020FHCAAO^T00020FHRSTS^D00030FHCDTN^T00100APCDTNQ^T00050FHCPRV^"

 +23       SET @DATA@(II)=@DATA@(II)_"T00015FHRAAD^T00060FHRCOD^T00010FHRMB^T00020FHRMBT^T00030FHRMBD^D00015FHCDTM^D00030FHRDTU"_$CHAR(30)

 +24      ;

 +25       SET FHCIEN=""

FOR

               SET FHCIEN=$ORDER(^AUPNFH("AC",DFN,FHCIEN))

               IF FHCIEN=""

                   QUIT

               Begin DoDot:1

 +26      ;

 +27               NEW APCDTNQ,BQICND,DIEN,FHCAAO,FHCDX,FHCDTM,FHCDTN,FHCNAR,FHCPRV,REIN

 +28               DO GETS^DIQ(9000014,FHCIEN,"**","IE","BQICND")

 +29      ;

 +30      ;Date Noted

 +31               SET FHCDTN=$GET(BQICND(9000014,FHCIEN_",",".03","I"))

 +32      ;

 +33      ;DX Code (Condition)

 +34      ;Using $$GET1^DIQ as GETS^DIQ sometimes omits .01 entry

                   SET DIEN=$$GET1^DIQ(9000014,FHCIEN_",",.01,"I")

 +35               IF DIEN=""

                       QUIT

 +36      ; csv

                   IF $$VERSION^XPDUTL("BCSV")

                       SET FHCDX=$$ICD9^BQIUL3(DIEN,FHCDTN,2)_"-"_$$ICD9^BQIUL3(DIEN,FHCDTN,4)

 +37               IF '$$VERSION^XPDUTL("BCSV")

                       SET FHCDX=$$GET1^DIQ(80,DIEN_",",.01,"E")_"-"_$$GET1^DIQ(80,DIEN_",",3,"E")

 +38               SET FHCDX=DIEN_$CHAR(28)_FHCDX

                   IF $PIECE(FHCDX,$CHAR(28))="-"

                       SET FHCDX=""

 +39      ;

 +40      ;Diagnosis Narrative (Provider Narrative)

 +41      ;S FHCNAR=$G(BQICND(9000014,FHCIEN_",",".04","E"))

 +42      ;

 +43      ;Narrative

 +44               NEW NIEN

 +45               SET APCDTNQ=""

 +46               SET NIEN=$GET(BQICND(9000014,FHCIEN_",",".04","I"))

 +47               IF $$PATCH^XPDUTL("BJPC*2.0*10")

                       SET FHCNAR=$$PNPROB^AUPNVUTL(NIEN)

 +48              IF '$TEST

                       SET FHCNAR=$GET(BQICND(9000014,FHCIEN_",",".04","E"))

 +49               SET APCDTNQ=NIEN_$CHAR(28)_FHCNAR

 +50               IF $PIECE(APCDTNQ,$CHAR(28))=""

                       SET APCDTNQ=""

 +51      ;

 +52      ;Age at Onset

 +53               SET FHCAAO=$GET(BQICND(9000014,FHCIEN_",",".11","I"))_$CHAR(28)_$GET(BQICND(9000014,FHCIEN_",",".11","E"))

 +54               IF $PIECE(FHCAAO,$CHAR(28))=""

                       SET FHCAAO=""

 +55      ;

 +56      ;Provider

 +57               SET FHCPRV=$GET(BQICND(9000014,FHCIEN_",",".08","I"))_$CHAR(28)_$GET(BQICND(9000014,FHCIEN_",",".08","E"))

 +58               IF $PIECE(FHCPRV,$CHAR(28))=""

                       SET FHCPRV=""

 +59      ;

 +60      ;Relation IEN

 +61               SET FHRIEN=$GET(BQICND(9000014,FHCIEN_",",".09","I"))

 +62               IF FHRIEN'=""

                       SET FAM(FHRIEN)=""

 +63      ;

 +64      ;Pull Relation Information - FHRREL, FHRDES, FHRSTS, FHRDTU, FHRMB, FHRMBT, FHRMBD, FHRAAD, FHRCOD

 +65               DO GFAM(FHRIEN)

 +66      ;

 +67      ;Date Last Modified

 +68               SET FHCDTM=$GET(BQICND(9000014,FHCIEN_",",".12","I"))

 +69      ;

 +70      ;Set up sorting array

 +71               SET ARRAY(RORD,RELNM,FHCIEN)=FHCIEN_U_FHRIEN_U_FHRREL_U_FHRDES_U_FHCDX_U_FHCNAR_U_FHCAAO_U_FHRSTS_U_$$FMTE^BQIUL1(FHCDTN)_U_APCDTNQ_U_FHCPRV_U_FHRAAD_U_FHRCOD_U_FHRMB_U_FHRMBT_U_FHRMBD_U_$$FMTE^BQIUL1(FHCDTM)_U_$$FMTE^BQIUL1(FHRDTU)_$CH

AR(30)

               End DoDot:1

 +72      ;

 +73       SET RIEN=""

FOR

               SET RIEN=$ORDER(^AUPNFHR("AA",DFN,RIEN))

               IF 'RIEN

                   QUIT

               Begin DoDot:1

 +74               SET FHRIEN=""

FOR

                       SET FHRIEN=$ORDER(^AUPNFHR("AA",DFN,RIEN,FHRIEN))

                       IF FHRIEN=""

                           QUIT

                       Begin DoDot:2

 +75                       IF $DATA(FAM(FHRIEN))

                               QUIT

 +76      ;

 +77      ; For family without diagnoses search FAMILY HISTORY FAMILY MEMBERS file

 +78                       DO GFAM(FHRIEN)

 +79                       SET ARRAY(RORD,RELNM,"R"_FHRIEN)=U_FHRIEN_U_FHRREL_U_FHRDES_U_U_U_U_FHRSTS_U_U_U_U_FHRAAD_U_FHRCOD_U_FHRMB_U_FHRMBT_U_FHRMBD_U_U_$$FMTE^BQIUL1(FHRDTU)_$CHAR(30)

                       End DoDot:2

               End DoDot:1

 +80      ;

 +81      ;Create record entries

 +82       SET RORD=""

FOR

               SET RORD=$ORDER(ARRAY(RORD))

               IF RORD=""

                   QUIT

               Begin DoDot:1

 +83               SET RELNM=""

FOR

                       SET RELNM=$ORDER(ARRAY(RORD,RELNM))

                       IF RELNM=""

                           QUIT

                       Begin DoDot:2

 +84                       SET FHCIEN=""

FOR

                               SET FHCIEN=$ORDER(ARRAY(RORD,RELNM,FHCIEN))

                               IF FHCIEN=""

                                   QUIT

                               Begin DoDot:3

 +85                               SET II=II+1

                                   SET @DATA@(II)=ARRAY(RORD,RELNM,FHCIEN)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +86       SET II=II+1

           SET @DATA@(II)=$CHAR(31)

 +87       QUIT

 +88      ;

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       ;

GFAM(FHRIEN) ; Get FAMILY HISTORY FAMILY MEMBERS Data

 +1       ;

 +2        NEW BQIREL,RIEN,RELT

 +3        SET (FHRREL,FHRDES,FHRSTS,FHRDTU,FHRMB,FHRMBT,FHRMBD,FHRAAD,FHRCOD)=""

 +4       ;

 +5        IF FHRIEN=""

               SET (RORD,RELNM)="~"

               QUIT

 +6       ;

 +7        DO GETS^DIQ(9000014.1,FHRIEN,"**","IE","BQIREL")

 +8       ;

 +9       ;Relative (Relation) and Sort variables

 +10       SET REIN=$GET(BQIREL(9000014.1,FHRIEN_",",".01","I"))

 +11       SET RELT=$GET(BQIREL(9000014.1,FHRIEN_",",".01","E"))

 +12       SET RELNM=RELT

           IF RELNM=""

               SET RELNM="~"

 +13       SET FHRREL=""

           IF REIN'=""

               SET FHRREL=REIN_$CHAR(28)_RELT

 +14       SET RORD=$$GET1^DIQ(9999999.36,REIN_",",2103,"E")

           IF RORD=""

               SET RORD="~"

 +15      ;

 +16      ;Relation Modifier (Description)

 +17       SET FHRDES=$GET(BQIREL(9000014.1,FHRIEN_",",".03","E"))

 +18      ;

 +19      ;Status

 +20       SET FHRSTS=$GET(BQIREL(9000014.1,FHRIEN_",",".04","I"))_$CHAR(28)_$GET(BQIREL(9000014.1,FHRIEN_",",".04","E"))

 +21       IF $PIECE(FHRSTS,$CHAR(28))=""

               SET FHRSTS=""

 +22      ;

 +23      ;Date Updated

 +24       SET FHRDTU=$GET(BQIREL(9000014.1,FHRIEN_",",".09","I"))

 +25      ;

 +26      ;Multiple Birth Status

 +27       SET FHRMB=$GET(BQIREL(9000014.1,FHRIEN_",",".07","I"))_$CHAR(28)_$GET(BQIREL(9000014.1,FHRIEN_",",".07","E"))

 +28       SET FHRMBD=FHRMB

 +29       IF $PIECE(FHRMB,$CHAR(28))=""

               SET FHRMB=""

 +30      ;

 +31      ;Multiple Birth Type

 +32       SET FHRMBT=$GET(BQIREL(9000014.1,FHRIEN_",",".08","I"))_$CHAR(28)_$GET(BQIREL(9000014.1,FHRIEN_",",".08","E"))

 +33       SET FHRMBD=FHRMBD_$CHAR(28)_FHRMBT

 +34       IF $PIECE(FHRMBT,$CHAR(28))=""

               SET FHRMBT=""

 +35      ;

 +36      ;Multiple Birth Display

 +37       IF $TRANSLATE(FHRMBD,$CHAR(28))=""

               SET FHRMBD=""

 +38      ;

 +39      ;Age at Death

 +40       SET FHRAAD=$GET(BQIREL(9000014.1,FHRIEN_",",".05","I"))_$CHAR(28)_$GET(BQIREL(9000014.1,FHRIEN_",",".05","E"))

 +41       IF $PIECE(FHRAAD,$CHAR(28))=""

               SET FHRAAD=""

 +42      ;

 +43      ;Cause of Death

 +44       SET FHRCOD=$GET(BQIREL(9000014.1,FHRIEN_",",".06","E"))

 +45      ;

 +46       QUIT

BQIPTFHR.m