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