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

BQIPTRPU.m

Go to the documentation of this file. 
  1. BQIPTRPU ;VNGT/HC/KML-REPRODUCTIVE FACTORS UPDATE ; 02 Jan 2008  12:27 PM
  1.  ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
  1.  ;
  1.  Q
  1.  ;
  1. UPD(DATA,DFN,RPARMS) ;EP - BQI UPDATE REPRODUCTIVE FACTORS
  1.  ;Input
  1.  ;  DFN    - Patient internal entry number
  1.  ;  RPARMS  - Data values
  1.  ;
  1.  N UID,II,VFIEN,RPFILE,API,BQINT,RPFIEN,BQIAPCD
  1.  N BQIDATA,ERROR,RESULT,DIC,DR,DA
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIPTRPU",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  N $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTRPU D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  S @DATA@(II)="I00010RESULT^T01024ERROR"_$C(30)
  1.  ;
  1.  S VFIEN=$O(^BQI(90506.3,"B","Reproductive Factors",""))
  1.  I VFIEN="" S BMXSEC="RPC Call Failed: Reproductive Factors Definition does not exist." Q
  1.  S RPFILE=$P(^BQI(90506.3,VFIEN,0),U,2)
  1.  S API=0 I $T(^APCDRF)'="" S API=1
  1.  ;
  1.  I $G(^AUPNREP(DFN,0))="" S RPFIEN=$$NREC(DFN) Q:$G(BMXSEC)]""  ; create new record if RPFIEN is null
  1.  ;
  1.  D GETS^DIQ(9000017,DFN_",","*","I","BQINT")
  1.  ;
  1.  D COLLECT(RPFILE,RPARMS,.BQIDATA,.BQIAPCD)
  1.  ;
  1.  S RESULT=$$FILEDATA(.BQIDATA,.BQIAPCD)
  1.  ;
  1.  S II=II+1,@DATA@(II)=RESULT_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. UPDFPM(DATA,DFN,FPMIEN,PARMS) ; EP - BQI UPDATE FAMILY PLANNING METHOD
  1.  ;Input
  1.  ;  DFN    - Patient internal entry number
  1.  ;  FPMIEN - FAMILY PLANNING METHOD IEN if null create a new one 
  1.  ;  PARMS  - Data values
  1.  ;
  1.  N UID,II,VFIEN,FILE,LIST,BN,BQ,PDATA,NAME,VALUE,PFIEN,PTYP,CHIEN,FIELD
  1.  N BQIDATA,ERROR,RESULT,DIC,DR,DA,BQINT,BQEXT,BQIAPCD
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("UPDFPM-BQIPTRPU",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  N $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTRPU D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  S @DATA@(II)="I00010RESULT^T001024ERROR"_$C(30)
  1.  ;
  1.  S RPFIEN=$G(RPFIEN,"")
  1.  ;
  1.  S VFIEN=$O(^BQI(90506.3,"B","Family Planning Method",""))
  1.  I VFIEN="" S BMXSEC="RPC Call Failed: Family Planning Method Definition does not exist." Q
  1.  S FILE=$P(^BQI(90506.3,VFIEN,0),U,2)
  1.  ;
  1.  ;
  1.  D COLLECT(RPFILE,RPARMS,.BQIDATA,.BQIAPCD)
  1.  ;
  1.  S RESULT=$$FILEDATA(.BQIDATA,.BQIAPCD)
  1.  ;
  1.  S II=II+1,@DATA@(II)=RESULT_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. NREC(BQIDFN) ; Create new record in file 9000017
  1.  N RPFY
  1.  ; call IHS PCC Package to file new entry if API program exists
  1.  I $T(^APCDRF)'="" S RPFY=$$RFADD^APCDRF(DFN) I RPFY=1 S RPFY=DFN
  1.  I '$D(RPFY)  D
  1.  . N X,DIC,DD,D0,DO,Y,DINUM
  1.  . I $P(^DPT(DFN,0),U,2)'="F" S RPFY="0^Patient not female." Q
  1.  . I $G(^AUPNREP(DFN,0))'="" S RPFY=DFN Q  ; Entry already exists
  1.  . S DIC="^AUPNREP(",DIC(0)="L",(DINUM,X)=DFN
  1.  . K DO,DD D FILE^DICN
  1.  . K DIC,DR,DA
  1.  . S RPFY=+Y
  1.  S:RPFY=-1 BMXSEC="RPC Call Failed: Error encountered while filing new entry in REPRODUCTIVE FACTORS file."
  1.  I +RPFY=0 S BMXSEC="RPC Call Failed: "_$P(RPFY,U,2)
  1.  Q RPFY
  1.  ;
  1. COLLECT(FILE,PARMS,ARRAYBQI,ARRYAPCD) ;
  1.  N LIST,BN,PDATA,NAME,VALUE,PFIEN,PTYPE,CHIEN,FIELD
  1.  S PARMS=$G(PARMS,"")
  1.  I PARMS="" D
  1.  . S LIST="",BN=""
  1.  . F  S BN=$O(PARMS(BN)) Q:BN=""  S LIST=LIST_PARMS(BN)
  1.  . K PARMS
  1.  . S PARMS=LIST
  1.  . K LIST
  1.  ;
  1.  F BQ=1:1:$L(PARMS,$C(28)) D  Q:$G(BMXSEC)'=""
  1.  . S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
  1.  . S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
  1.  . S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
  1.  . I PFIEN="" S BMXSEC="RPC Call Failed: "_NAME_" not a valid parameter for this update" Q
  1.  . ;I $P(^BQI(90506.3,VFIEN,10,PFIEN,0),U,11)=1 S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,PFIEN))
  1.  . S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U) ; code type could be 'D' date, 'N' numeric, 'C' choice, 'X' text
  1.  . I NAME="RFLMP"!(NAME="RFCFPMDT")!(NAME="RFEDCDT") S VALUE=$$DATE^BQIUL1(VALUE)
  1.  . I PTYP="D" S VALUE=$$DATE^BQIUL1(VALUE)
  1.  . I PTYP="C" D
  1.  .. I VALUE="" Q
  1.  .. S CHIEN=$O(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
  1.  .. I CHIEN="" S CHIEN=$O(^BQI(90506.3,VFIEN,10,PFIEN,5,"C",VALUE,""))
  1.  .. I CHIEN="" Q
  1.  .. S VALUE=$P(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
  1.  .. ;I API S VALUE=$P(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,1)
  1.  . S FIELD=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,3)),U)
  1.  . ;S (ARRAYBQI(FILE,DFN_",",FIELD),ARRYAPCD(FIELD))=VALUE
  1.  . ;S @NAME=VALUE
  1.  . I $G(BQINT(FILE,DFN_",",FIELD,"I"))'="",VALUE="" S VALUE="@"
  1.  . I VALUE'="" D UP
  1.  . I FIELD=3,VALUE'="" S FIELD=3.1,VALUE=DT D UP
  1.  . I FIELD=3.05,VALUE'="" S VALUE=$$DATE^BQIUL1(VALUE) D UP
  1.  . I FIELD=4,VALUE'="" S FIELD=4.1,VALUE=DT D UP
  1.  . I FIELD=4.05,VALUE'="" S FIELD=4.1,VALUE=DT D UP
  1.  . I FIELD=2.01,VALUE'="" S FIELD=2.02,VALUE=DT D UP
  1.  . ;I VALUE="" S VALUE="@"
  1.  Q
  1.  ;
  1. FILEDATA(ARRAYBQI,ARYAPCD) ; update existing record with data returned from CMET
  1.  N BQIRET,RETVAL
  1.  K ERROR
  1.  I API,$D(ARYAPCD)>0 S BQIRET=0 D RHEDIT^APCDRF("I",DFN,.ARYAPCD,BQIRET)
  1.  I 'API,$D(ARRAYBQI)>0 D FILE^DIE("","ARRAYBQI","ERROR")
  1.  S RETVAL=1_U
  1.  I $D(ERROR)>0 S RETVAL=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
  1.  Q RETVAL
  1.  ;
  1. INIT(DATA,DFN) ; EP - BQI REP FAC INIT TRIG
  1.  NEW UID,II,VALUE,SOURCE,HELP,ABLE,REQ,CLEAR,TYPE,CPS,CLFLAG
  1.  ;
  1.  S DFN=$G(DFN,"")
  1.  ;
  1.  ;Pull Current Pregnancy Status
  1.  S CPS=$$GET1^DIQ(9000017,DFN_",",1101,"I")
  1.  ;
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIPTRPU",UID))
  1.  K @DATA
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTRPU D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  ;Define Header
  1.  S @DATA@(II)="T00008SOURCE^T00001CODE_TYPE^T01024PARMS^T00030PROP_VALUE^T00001ABLE_FLAG^T00001REQ_OPT^T00200HELP_TEXT^T01024CLEAR_FIELDS^T00001CLEAR_FLAG"_$C(30)
  1.  ;
  1.  S ABLE="Y"
  1.  I CPS'="Y" S ABLE="N"
  1.  S SOURCE="RFDFEDD",VALUE="",HELP="",REQ="",CLEAR="",CLFLAG="N",TYPE="C" D REC
  1.  S SOURCE="RFEDDLMP",VALUE="",HELP="",REQ="",CLEAR="",CLFLAG="N",TYPE="C" D REC
  1.  S SOURCE="RFEDDULT",VALUE="",HELP="",REQ="",CLEAR="",CLFLAG="N",TYPE="C" D REC
  1.  S SOURCE="RFEDDCLP",VALUE="",HELP="",REQ="",CLEAR="",CLFLAG="N",TYPE="C" D REC
  1.  S SOURCE="RFEDDUNK",VALUE="",HELP="",REQ="",CLEAR="",CLFLAG="N",TYPE="C" D REC
  1.  S SOURCE="RFEDDDPV",VALUE="",HELP="",REQ="",CLEAR="",CLFLAG="N",TYPE="C" D REC
  1.  S SOURCE="RFEDDLPV",VALUE="",HELP="",REQ="",CLEAR="",CLFLAG="N",TYPE="C" D REC
  1.  S SOURCE="RFEDDUPV",VALUE="",HELP="",REQ="",CLEAR="",CLFLAG="N",TYPE="C" D REC
  1.  S SOURCE="RFEDDCPV",VALUE="",HELP="",REQ="",CLEAR="",CLFLAG="N",TYPE="C" D REC
  1.  S SOURCE="RFEDDMPV",VALUE="",HELP="",REQ="",CLEAR="",CLFLAG="N",TYPE="C" D REC
  1.  ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1.  ;Set up entry
  1. REC S II=II+1,@DATA@(II)=$G(SOURCE)_U_$G(TYPE)_U_$G(VALUE)_U_U_$G(ABLE)_U_$G(REQ)_U_$G(HELP)_U_$G(CLEAR)_U_$G(CLFLAG)_$C(30)
  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. UP ;
  1.  S (ARRAYBQI(FILE,DFN_",",FIELD),ARRYAPCD(FIELD))=VALUE
  1.  Q