Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQIVFTRF

BQIVFTRF.m

Go to the documentation of this file. 
  1. BQIVFTRF ;VNGT/HS/BEE - Trigger Family History ; 04 Jun 2008  4:24 PM
  1.  ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
  1.  Q
  1.  ;
  1. EN(DATA,TEXT) ;EP - BQI VFILE TRIGGER FH
  1.  ;
  1.  ; Input
  1.  ;   TEXT  - Narrative Text
  1.  ;
  1.  NEW UID,II,VALUE,NARR,SOURCE
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIVFTRF",UID))
  1.  K @DATA
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFTRF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  S SOURCE="APCDTNQ",VALUE=""
  1.  S DIC(0)="LX",DIC="^AUTNPOV(",DLAYGO=9999999.27,X=TEXT
  1.  D ^DIC
  1.  S IEN=+Y
  1.  I IEN=-1 K DO,DD D FILE^DICN S IEN=+Y
  1.  S VALUE=IEN_$C(29)_TEXT
  1.  S @DATA@(II)="T00008SOURCE^T00001CODE_TYPE^T01024PARMS"_$C(30)
  1.  S II=II+1,@DATA@(II)=SOURCE_U_"C"_U_VALUE_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. TRGR(DATA,STS,MLTB) ; EP - BQI VFILE TRG FH REL
  1.  ;
  1.  ; Input
  1.  ;   STS - The FHRSTS ("STATUS") CODE value
  1.  ;   MLTB - The FHRMB ("MULTIPLE BIRTH?") CODE value
  1.  ;
  1.  NEW BQIREC,UID,II
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIVFTRF",UID))
  1.  K @DATA
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFTRF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  ;Version check
  1.  I $$VERSION^XPDUTL("BJPC")<2.0 S BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS" Q
  1.  ;
  1.  ;Define Header
  1.  S @DATA@(II)="T00008SOURCE^T00030VALUE^T00001ABLE_FLAG^T01024CLEAR_FIELDS^T00200HELP_TEXT"_$C(30)
  1.  ;
  1.  ;Initialize Records
  1.  S STS=$G(STS,""),MLTB=$G(MLTB,"")
  1.  S BQIREC("FHRAAD")="FHRAAD"_U_U_"N"_U_"FHRAAD"_U_$C(30)
  1.  S BQIREC("FHRCOD")="FHRCOD"_U_U_"N"_U_"FHRCOD"_U_$C(30)
  1.  S BQIREC("FHRMBT")="FHRMBT"_U_U_"N"_U_"FHRMBT"_U_$C(30)
  1.  ;
  1.  ;Handle Status
  1.  I STS="DECEASED"!(STS="D") D
  1.  . S $P(BQIREC("FHRAAD"),U,3,4)="Y^"
  1.  . S $P(BQIREC("FHRCOD"),U,3,4)="Y^"
  1.  ;
  1.  ;Handle Multiple Birth?
  1.  I MLTB="YES"!(MLTB="Y") D
  1.  . S $P(BQIREC("FHRMBT"),U,3,4)="Y^"
  1.  ;
  1.  S II=II+1,@DATA@(II)=BQIREC("FHRAAD")
  1.  S II=II+1,@DATA@(II)=BQIREC("FHRCOD")
  1.  S II=II+1,@DATA@(II)=BQIREC("FHRMBT")
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  ;
  1. XTRGR Q
  1.  ;
  1. TRGC(DATA,FHCDX,TEXT) ; EP - BQI VFILE TRG FH CND
  1.  ;
  1.  ; Input
  1.  ;   FHCDX - Diagnosis Code IEN
  1.  ;   TEXT  - Narrative Text
  1.  ;
  1.  NEW BQIREC,UID,II
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIVFTRF",UID))
  1.  K @DATA
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFTRF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  ;Version check
  1.  I $$VERSION^XPDUTL("BJPC")<2.0 S BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS" Q
  1.  ;
  1.  ;Define Header
  1.  S @DATA@(II)="T00008SOURCE^T00030VALUE^T00001ABLE_FLAG^T01024CLEAR_FIELDS^T00200HELP_TEXT"_$C(30)
  1.  ;
  1.  S FHCDX=$G(FHCDX,""),TEXT=$G(TEXT,"")
  1.  S BQIREC("APCDTNQ")="APCDTNQ"_U_U_"N"_U_"APCDTNQ"_U_$C(30)
  1.  S BQIREC("FHCNAR")="FHCNAR"_U_TEXT_U_"Y"_U_U_$C(30)
  1.  ;
  1.  ;If TEXT is blank plug in DX description
  1.  I FHCDX]"",TEXT="" D
  1.  . I $$VERSION^XPDUTL("BCSV") S TEXT=$P($$ICDDX^ICDCODE(FHCDX,DT),U,4) ;Adapted from COND^APCDFH (APCD FAMILY HISTORY ADD/EDIT option)
  1.  ;
  1.  ;If TEXT present, file entry in 9999999.27
  1.  I TEXT]"" D
  1.  .N DIC,DLAYGO,SOURCE,VALUE,X,Y,IEN
  1.  .S SOURCE="APCDTNQ"
  1.  .S DIC(0)="LX",DIC="^AUTNPOV(",DLAYGO=9999999.27,X=TEXT
  1.  .D ^DIC
  1.  .S IEN=+Y
  1.  .I IEN=-1 K DO,DD D FILE^DICN S IEN=+Y
  1.  .S $P(BQIREC("APCDTNQ"),U,2)=IEN_$C(29)_TEXT
  1.  .S $P(BQIREC("APCDTNQ"),U,4)=""
  1.  .S $P(BQIREC("FHCNAR"),U,2)=TEXT
  1.  ;
  1.  S II=II+1,@DATA@(II)=BQIREC("APCDTNQ")
  1.  S II=II+1,@DATA@(II)=BQIREC("FHCNAR")
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. INIT(DATA,FHRIEN) ; EP - BQI VFILE INITIAL FH REL
  1.  ;
  1.  ;Input
  1.  ; FHRIEN - FAMILY HISTORY FAMILY MEMBER IEN (NULL FOR NEW)
  1.  ; 
  1.  NEW BQIREC,II,UID
  1.  ;
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIVFTRF",UID))
  1.  K @DATA
  1.  S FHRIEN=$G(FHRIEN,"")
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFTRF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  S @DATA@(II)="T00008SOURCE^T00030VALUE^T00001ABLE_FLAG^T01024CLEAR_FIELDS^T00200HELP_TEXT"_$C(30)
  1.  ;
  1.  ;Version check
  1.  I $$VERSION^XPDUTL("BJPC")<2.0 S BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS" Q
  1.  ;
  1.  ;Initialize Records
  1.  S BQIREC("FHRAAD")="FHRAAD"_U_U_"N"_U_"FHRAAD"_U_$C(30)
  1.  S BQIREC("FHRCOD")="FHRCOD"_U_U_"N"_U_"FHRCOD"_U_$C(30)
  1.  S BQIREC("FHRMBT")="FHRMBT"_U_U_"N"_U_"FHRMBT"_U_$C(30)
  1.  ;
  1.  I FHRIEN'="" D
  1.  . N BQIREL,FHRMB,FHRSTS
  1.  . D GETS^DIQ(9000014.1,FHRIEN_",",".04;.07","","BQIREL")
  1.  . ;
  1.  . ;Age At Death/Cause Of Death
  1.  . S FHRSTS=$G(BQIREL(9000014.1,FHRIEN_",",".04"))
  1.  . I FHRSTS="DECEASED" D
  1.  .. S $P(BQIREC("FHRAAD"),U,3,4)="Y^"
  1.  .. S $P(BQIREC("FHRCOD"),U,3,4)="Y^"
  1.  . ;
  1.  . ;Multiple Birth Type
  1.  . S FHRMB=$G(BQIREL(9000014.1,FHRIEN_",",".07"))
  1.  . I FHRMB="YES" S $P(BQIREC("FHRMBT"),U,3,4)="Y^"
  1.  ;
  1.  S II=II+1,@DATA@(II)=BQIREC("FHRAAD")
  1.  S II=II+1,@DATA@(II)=BQIREC("FHRCOD")
  1.  S II=II+1,@DATA@(II)=BQIREC("FHRMBT")
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q