BQIVFTRF ;VNGT/HS/BEE - Trigger Family History ; 04 Jun 2008 4:24 PM
;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
Q
;
EN(DATA,TEXT) ;EP - BQI VFILE TRIGGER FH
;
; Input
; TEXT - Narrative Text
;
NEW UID,II,VALUE,NARR,SOURCE
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIVFTRF",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFTRF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S SOURCE="APCDTNQ",VALUE=""
S DIC(0)="LX",DIC="^AUTNPOV(",DLAYGO=9999999.27,X=TEXT
D ^DIC
S IEN=+Y
I IEN=-1 K DO,DD D FILE^DICN S IEN=+Y
S VALUE=IEN_$C(29)_TEXT
S @DATA@(II)="T00008SOURCE^T00001CODE_TYPE^T01024PARMS"_$C(30)
S II=II+1,@DATA@(II)=SOURCE_U_"C"_U_VALUE_$C(30)
S II=II+1,@DATA@(II)=$C(31)
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
;
TRGR(DATA,STS,MLTB) ; EP - BQI VFILE TRG FH REL
;
; Input
; STS - The FHRSTS ("STATUS") CODE value
; MLTB - The FHRMB ("MULTIPLE BIRTH?") CODE value
;
NEW BQIREC,UID,II
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIVFTRF",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFTRF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
;Version check
I $$VERSION^XPDUTL("BJPC")<2.0 S BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS" Q
;
;Define Header
S @DATA@(II)="T00008SOURCE^T00030VALUE^T00001ABLE_FLAG^T01024CLEAR_FIELDS^T00200HELP_TEXT"_$C(30)
;
;Initialize Records
S STS=$G(STS,""),MLTB=$G(MLTB,"")
S BQIREC("FHRAAD")="FHRAAD"_U_U_"N"_U_"FHRAAD"_U_$C(30)
S BQIREC("FHRCOD")="FHRCOD"_U_U_"N"_U_"FHRCOD"_U_$C(30)
S BQIREC("FHRMBT")="FHRMBT"_U_U_"N"_U_"FHRMBT"_U_$C(30)
;
;Handle Status
I STS="DECEASED"!(STS="D") D
. S $P(BQIREC("FHRAAD"),U,3,4)="Y^"
. S $P(BQIREC("FHRCOD"),U,3,4)="Y^"
;
;Handle Multiple Birth?
I MLTB="YES"!(MLTB="Y") D
. S $P(BQIREC("FHRMBT"),U,3,4)="Y^"
;
S II=II+1,@DATA@(II)=BQIREC("FHRAAD")
S II=II+1,@DATA@(II)=BQIREC("FHRCOD")
S II=II+1,@DATA@(II)=BQIREC("FHRMBT")
S II=II+1,@DATA@(II)=$C(31)
;
XTRGR Q
;
TRGC(DATA,FHCDX,TEXT) ; EP - BQI VFILE TRG FH CND
;
; Input
; FHCDX - Diagnosis Code IEN
; TEXT - Narrative Text
;
NEW BQIREC,UID,II
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIVFTRF",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFTRF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
;Version check
I $$VERSION^XPDUTL("BJPC")<2.0 S BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS" Q
;
;Define Header
S @DATA@(II)="T00008SOURCE^T00030VALUE^T00001ABLE_FLAG^T01024CLEAR_FIELDS^T00200HELP_TEXT"_$C(30)
;
S FHCDX=$G(FHCDX,""),TEXT=$G(TEXT,"")
S BQIREC("APCDTNQ")="APCDTNQ"_U_U_"N"_U_"APCDTNQ"_U_$C(30)
S BQIREC("FHCNAR")="FHCNAR"_U_TEXT_U_"Y"_U_U_$C(30)
;
;If TEXT is blank plug in DX description
I FHCDX]"",TEXT="" D
. I $$VERSION^XPDUTL("BCSV") S TEXT=$P($$ICDDX^ICDCODE(FHCDX,DT),U,4) ;Adapted from COND^APCDFH (APCD FAMILY HISTORY ADD/EDIT option)
;
;If TEXT present, file entry in 9999999.27
I TEXT]"" D
.N DIC,DLAYGO,SOURCE,VALUE,X,Y,IEN
.S SOURCE="APCDTNQ"
.S DIC(0)="LX",DIC="^AUTNPOV(",DLAYGO=9999999.27,X=TEXT
.D ^DIC
.S IEN=+Y
.I IEN=-1 K DO,DD D FILE^DICN S IEN=+Y
.S $P(BQIREC("APCDTNQ"),U,2)=IEN_$C(29)_TEXT
.S $P(BQIREC("APCDTNQ"),U,4)=""
.S $P(BQIREC("FHCNAR"),U,2)=TEXT
;
S II=II+1,@DATA@(II)=BQIREC("APCDTNQ")
S II=II+1,@DATA@(II)=BQIREC("FHCNAR")
S II=II+1,@DATA@(II)=$C(31)
Q
;
INIT(DATA,FHRIEN) ; EP - BQI VFILE INITIAL FH REL
;
;Input
; FHRIEN - FAMILY HISTORY FAMILY MEMBER IEN (NULL FOR NEW)
;
NEW BQIREC,II,UID
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIVFTRF",UID))
K @DATA
S FHRIEN=$G(FHRIEN,"")
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFTRF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="T00008SOURCE^T00030VALUE^T00001ABLE_FLAG^T01024CLEAR_FIELDS^T00200HELP_TEXT"_$C(30)
;
;Version check
I $$VERSION^XPDUTL("BJPC")<2.0 S BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS" Q
;
;Initialize Records
S BQIREC("FHRAAD")="FHRAAD"_U_U_"N"_U_"FHRAAD"_U_$C(30)
S BQIREC("FHRCOD")="FHRCOD"_U_U_"N"_U_"FHRCOD"_U_$C(30)
S BQIREC("FHRMBT")="FHRMBT"_U_U_"N"_U_"FHRMBT"_U_$C(30)
;
I FHRIEN'="" D
. N BQIREL,FHRMB,FHRSTS
. D GETS^DIQ(9000014.1,FHRIEN_",",".04;.07","","BQIREL")
. ;
. ;Age At Death/Cause Of Death
. S FHRSTS=$G(BQIREL(9000014.1,FHRIEN_",",".04"))
. I FHRSTS="DECEASED" D
.. S $P(BQIREC("FHRAAD"),U,3,4)="Y^"
.. S $P(BQIREC("FHRCOD"),U,3,4)="Y^"
. ;
. ;Multiple Birth Type
. S FHRMB=$G(BQIREL(9000014.1,FHRIEN_",",".07"))
. I FHRMB="YES" S $P(BQIREC("FHRMBT"),U,3,4)="Y^"
;
S II=II+1,@DATA@(II)=BQIREC("FHRAAD")
S II=II+1,@DATA@(II)=BQIREC("FHRCOD")
S II=II+1,@DATA@(II)=BQIREC("FHRMBT")
S II=II+1,@DATA@(II)=$C(31)
Q
BQIVFTRF ;VNGT/HS/BEE - Trigger Family History ; 04 Jun 2008 4:24 PM
+1 ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
+2 QUIT
+3 ;
EN(DATA,TEXT) ;EP - BQI VFILE TRIGGER FH
+1 ;
+2 ; Input
+3 ; TEXT - Narrative Text
+4 ;
+5 NEW UID,II,VALUE,NARR,SOURCE
+6 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+7 SET DATA=$NAME(^TMP("BQIVFTRF",UID))
+8 KILL @DATA
+9 SET II=0
+10 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIVFTRF D UNWIND^%ZTER"
+11 SET SOURCE="APCDTNQ"
SET VALUE=""
+12 SET DIC(0)="LX"
SET DIC="^AUTNPOV("
SET DLAYGO=9999999.27
SET X=TEXT
+13 DO ^DIC
+14 SET IEN=+Y
+15 IF IEN=-1
KILL DO,DD
DO FILE^DICN
SET IEN=+Y
+16 SET VALUE=IEN_$CHAR(29)_TEXT
+17 SET @DATA@(II)="T00008SOURCE^T00001CODE_TYPE^T01024PARMS"_$CHAR(30)
+18 SET II=II+1
SET @DATA@(II)=SOURCE_U_"C"_U_VALUE_$CHAR(30)
+19 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+20 QUIT
+21 ;
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 ;
TRGR(DATA,STS,MLTB) ; EP - BQI VFILE TRG FH REL
+1 ;
+2 ; Input
+3 ; STS - The FHRSTS ("STATUS") CODE value
+4 ; MLTB - The FHRMB ("MULTIPLE BIRTH?") CODE value
+5 ;
+6 NEW BQIREC,UID,II
+7 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+8 SET DATA=$NAME(^TMP("BQIVFTRF",UID))
+9 KILL @DATA
+10 SET II=0
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIVFTRF D UNWIND^%ZTER"
+12 ;
+13 ;Version check
+14 IF $$VERSION^XPDUTL("BJPC")<2.0
SET BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS"
QUIT
+15 ;
+16 ;Define Header
+17 SET @DATA@(II)="T00008SOURCE^T00030VALUE^T00001ABLE_FLAG^T01024CLEAR_FIELDS^T00200HELP_TEXT"_$CHAR(30)
+18 ;
+19 ;Initialize Records
+20 SET STS=$GET(STS,"")
SET MLTB=$GET(MLTB,"")
+21 SET BQIREC("FHRAAD")="FHRAAD"_U_U_"N"_U_"FHRAAD"_U_$CHAR(30)
+22 SET BQIREC("FHRCOD")="FHRCOD"_U_U_"N"_U_"FHRCOD"_U_$CHAR(30)
+23 SET BQIREC("FHRMBT")="FHRMBT"_U_U_"N"_U_"FHRMBT"_U_$CHAR(30)
+24 ;
+25 ;Handle Status
+26 IF STS="DECEASED"!(STS="D")
Begin DoDot:1
+27 SET $PIECE(BQIREC("FHRAAD"),U,3,4)="Y^"
+28 SET $PIECE(BQIREC("FHRCOD"),U,3,4)="Y^"
End DoDot:1
+29 ;
+30 ;Handle Multiple Birth?
+31 IF MLTB="YES"!(MLTB="Y")
Begin DoDot:1
+32 SET $PIECE(BQIREC("FHRMBT"),U,3,4)="Y^"
End DoDot:1
+33 ;
+34 SET II=II+1
SET @DATA@(II)=BQIREC("FHRAAD")
+35 SET II=II+1
SET @DATA@(II)=BQIREC("FHRCOD")
+36 SET II=II+1
SET @DATA@(II)=BQIREC("FHRMBT")
+37 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+38 ;
XTRGR QUIT
+1 ;
TRGC(DATA,FHCDX,TEXT) ; EP - BQI VFILE TRG FH CND
+1 ;
+2 ; Input
+3 ; FHCDX - Diagnosis Code IEN
+4 ; TEXT - Narrative Text
+5 ;
+6 NEW BQIREC,UID,II
+7 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+8 SET DATA=$NAME(^TMP("BQIVFTRF",UID))
+9 KILL @DATA
+10 SET II=0
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIVFTRF D UNWIND^%ZTER"
+12 ;
+13 ;Version check
+14 IF $$VERSION^XPDUTL("BJPC")<2.0
SET BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS"
QUIT
+15 ;
+16 ;Define Header
+17 SET @DATA@(II)="T00008SOURCE^T00030VALUE^T00001ABLE_FLAG^T01024CLEAR_FIELDS^T00200HELP_TEXT"_$CHAR(30)
+18 ;
+19 SET FHCDX=$GET(FHCDX,"")
SET TEXT=$GET(TEXT,"")
+20 SET BQIREC("APCDTNQ")="APCDTNQ"_U_U_"N"_U_"APCDTNQ"_U_$CHAR(30)
+21 SET BQIREC("FHCNAR")="FHCNAR"_U_TEXT_U_"Y"_U_U_$CHAR(30)
+22 ;
+23 ;If TEXT is blank plug in DX description
+24 IF FHCDX]""
IF TEXT=""
Begin DoDot:1
+25 ;Adapted from COND^APCDFH (APCD FAMILY HISTORY ADD/EDIT option)
IF $$VERSION^XPDUTL("BCSV")
SET TEXT=$PIECE($$ICDDX^ICDCODE(FHCDX,DT),U,4)
End DoDot:1
+26 ;
+27 ;If TEXT present, file entry in 9999999.27
+28 IF TEXT]""
Begin DoDot:1
+29 NEW DIC,DLAYGO,SOURCE,VALUE,X,Y,IEN
+30 SET SOURCE="APCDTNQ"
+31 SET DIC(0)="LX"
SET DIC="^AUTNPOV("
SET DLAYGO=9999999.27
SET X=TEXT
+32 DO ^DIC
+33 SET IEN=+Y
+34 IF IEN=-1
KILL DO,DD
DO FILE^DICN
SET IEN=+Y
+35 SET $PIECE(BQIREC("APCDTNQ"),U,2)=IEN_$CHAR(29)_TEXT
+36 SET $PIECE(BQIREC("APCDTNQ"),U,4)=""
+37 SET $PIECE(BQIREC("FHCNAR"),U,2)=TEXT
End DoDot:1
+38 ;
+39 SET II=II+1
SET @DATA@(II)=BQIREC("APCDTNQ")
+40 SET II=II+1
SET @DATA@(II)=BQIREC("FHCNAR")
+41 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+42 QUIT
+43 ;
INIT(DATA,FHRIEN) ; EP - BQI VFILE INITIAL FH REL
+1 ;
+2 ;Input
+3 ; FHRIEN - FAMILY HISTORY FAMILY MEMBER IEN (NULL FOR NEW)
+4 ;
+5 NEW BQIREC,II,UID
+6 ;
+7 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+8 SET DATA=$NAME(^TMP("BQIVFTRF",UID))
+9 KILL @DATA
+10 SET FHRIEN=$GET(FHRIEN,"")
+11 SET II=0
+12 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIVFTRF D UNWIND^%ZTER"
+13 SET @DATA@(II)="T00008SOURCE^T00030VALUE^T00001ABLE_FLAG^T01024CLEAR_FIELDS^T00200HELP_TEXT"_$CHAR(30)
+14 ;
+15 ;Version check
+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 ;Initialize Records
+19 SET BQIREC("FHRAAD")="FHRAAD"_U_U_"N"_U_"FHRAAD"_U_$CHAR(30)
+20 SET BQIREC("FHRCOD")="FHRCOD"_U_U_"N"_U_"FHRCOD"_U_$CHAR(30)
+21 SET BQIREC("FHRMBT")="FHRMBT"_U_U_"N"_U_"FHRMBT"_U_$CHAR(30)
+22 ;
+23 IF FHRIEN'=""
Begin DoDot:1
+24 NEW BQIREL,FHRMB,FHRSTS
+25 DO GETS^DIQ(9000014.1,FHRIEN_",",".04;.07","","BQIREL")
+26 ;
+27 ;Age At Death/Cause Of Death
+28 SET FHRSTS=$GET(BQIREL(9000014.1,FHRIEN_",",".04"))
+29 IF FHRSTS="DECEASED"
Begin DoDot:2
+30 SET $PIECE(BQIREC("FHRAAD"),U,3,4)="Y^"
+31 SET $PIECE(BQIREC("FHRCOD"),U,3,4)="Y^"
End DoDot:2
+32 ;
+33 ;Multiple Birth Type
+34 SET FHRMB=$GET(BQIREL(9000014.1,FHRIEN_",",".07"))
+35 IF FHRMB="YES"
SET $PIECE(BQIREC("FHRMBT"),U,3,4)="Y^"
End DoDot:1
+36 ;
+37 SET II=II+1
SET @DATA@(II)=BQIREC("FHRAAD")
+38 SET II=II+1
SET @DATA@(II)=BQIREC("FHRCOD")
+39 SET II=II+1
SET @DATA@(II)=BQIREC("FHRMBT")
+40 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+41 QUIT
