BQIPTRP1 ;VNGT/HS/ALA - Patient Reproductive Factors ; 06 May 2008 7:40 PM
;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
;
REP(DATA,DFN,EDT) ; EP -- BQI PATIENT REPRODUCTIVE FACS
;
;Description - all the reproductive factors that a patient has
;
;Input
; DFN - Patient internal entry number
; EDT - 1 - Call was from Edit Load, otherwise Null
;
NEW UID,II,SEX,AGE,DIEN,DORD,CIEN,CLIST,BQIACT,ERROR,FIEN,VER,EDFLD,FDATA
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTRP1",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTRP1 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S DIEN=$O(^BQI(90506.3,"B","Reproductive Factors","")) I DIEN="" S BMXSEC="Reproductive Factors Definition Issue" Q
S EDT=$G(EDT,"")
S SEX=$$GET1^DIQ(2,DFN_",",.02,"I"),AGE=$$AGE^BQIAGE(DFN)
I SEX'="F" D Q
. S @DATA@(II)="I00010RESULT^T00080MESSAGE"_$C(30)
. S II=II+1,@DATA@(II)="-1^RPC Failed: Patient is not Female"_$C(30)
. S II=II+1,@DATA@(II)=$C(31)
;
S FDATA=""
S @DATA@(II)="T00010COLUMN_NAME^T00045COLUMN_DESC^T00120COLUMN_VALUE^D00030DATE_LAST_MODIFIED^T00075PRV_LAST_MODIFIED"_$C(30)
;
;Set up EDD field array
D EDFLD
;
;Update VDEF Reproductive Factors entry
D UVDEF()
;
;Loop through GRID ORDER and get each row
S DORD="" F S DORD=$O(^BQI(90506.3,DIEN,10,"AF",DORD)) Q:DORD="" S CIEN="" F S CIEN=$O(^BQI(90506.3,DIEN,10,"AF",DORD,CIEN)) Q:CIEN="" D PFLD(DIEN,CIEN,EDT,FDATA)
;
;Age check
I 'FDATA,AGE<10 D Q
. K @DATA
. S @DATA@(II)="I00010RESULT^T00080MESSAGE"_$C(30)
. S II=II+1,@DATA@(II)="-1^RPC Failed: Patient is less than 10 years of age"_$C(30)
. S II=II+1,@DATA@(II)=$C(31)
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
CMETH(DATA,DFN) ; EP -- BQI GET PATIENT CON METH
;
NEW UID,II,HDR,MIEN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTRP1",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTRP1 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S HDR="I00010CMIEN^T00050RFFPMT^D00030RFFPBDT^D00030RFFPEDT^T00100RFCMDSC^T00100RFCMCMT^D00030RFCFUPD"
S @DATA@(II)=HDR_$C(30)
;
;Pull Contraception Method Information
S MIEN=0 F S MIEN=$O(^AUPNREP(DFN,2101,MIEN)) Q:'MIEN D
. ;
. NEW DA,IENS,METH,XMTH,CBEG,CEND,CDIS,CCOM,CLDT
. S DA(1)=DFN,DA=MIEN,IENS=$$IENS^DILF(.DA)
. S METH=$$GET1^DIQ(9000017.02101,IENS,.01,"I")
. S XMTH=$$GET1^DIQ(9000017.02101,IENS,.01,"E")
. S CBEG=$$FMTE^BQIUL1($$GET1^DIQ(9000017.02101,IENS,.02,"I"))
. S CEND=$$FMTE^BQIUL1($$GET1^DIQ(9000017.02101,IENS,.03,"I"))
. S CLDT=$$FMTE^BQIUL1($$GET1^DIQ(9000017.02101,IENS,.04,"I"))
. S CDIS=$$GET1^DIQ(9000017.02101,IENS,.05,"E")
. S CCOM=$$GET1^DIQ(9000017.02101,IENS,.06,"E")
. S II=II+1,@DATA@(II)=MIEN_U_METH_$C(28)_XMTH_U_CBEG_U_CEND_U_CDIS_U_CCOM_U_CLDT_$C(30)
;
S II=II+1,@DATA@(II)=$C(31)
Q
;
UPDCM(DATA,BQIDFN,BQIIEN,BQIED,PARMS) ; EP - BQI UPD PAT CMETH
; Input parameters
; BQIDFN - Patient DFN
; BQIIEN - Contraception Method Entry IEN
; BQIED - E for Add/Edit, D for Delete
; PARMS - Parameters and their values
;
NEW UID,II,VFIEN,FILE,BQ,RFFPMT,RFFPBDT,RFFPEDT,RFCMDSC,RFCMCMT,RFCFUPD
NEW DA,IENS,BQ,BQICMT,ERROR,RESULT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTRP1",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTRP1 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T01024MSG^I00010HIDE_CMIEN"_$C(30)
;
S BQIIEN=$G(BQIIEN,"")
S PARMS=$G(PARMS,"")
S RFFPMT=$G(RFFPMT,""),RFFPBDT=$G(RFFPBDT,""),RFFPEDT=$G(RFFPEDT,"")
S RFCMDSC=$G(RFCMDSC,""),RFCMCMT=$G(RFCMCMT,""),RFCFUPD=$G(RFCFUPD,"")
;
I PARMS="" D
. NEW LIST,BN
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
S VFIEN=$O(^BQI(90506.3,"B","Contraceptive Methods",""))
I VFIEN="" S BMXSEC="RPC Call Failed: Contraceptive Methods VDEF does not exist." Q
S FILE=$P(^BQI(90506.3,VFIEN,0),U,2)
;
;Process Deletes
I BQIED="D" D G XUPDCM
. NEW DA,IENS
. S DA(1)=BQIDFN,DA=BQIIEN,IENS=$$IENS^DILF(.DA)
. S BQICMT(FILE,IENS,".01")="@"
;
F BQ=1:1:$L(PARMS,$C(28)) D Q:$G(BMXSEC)'=""
. NEW PDATA,NAME,VALUE,PFIEN,PTYP,CHIEN
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. I VALUE="" S VALUE="@"
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
. I PTYP="D" S VALUE=$$DATE^BQIUL1(VALUE)
. I PTYP="C" D
.. S CHIEN=$O(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
.. S VALUE=$P(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
. S @NAME=VALUE
;
I BQIIEN="",RFFPMT="" S BMXSEC="RPC Call Failed: No Contraceptive Method passed in." Q
I BQIIEN="" S BQIIEN=$$ADD(BQIDFN,RFFPMT)
;
S DA(1)=BQIDFN,DA=BQIIEN,IENS=$$IENS^DILF(.DA)
;
F BQ=1:1:$L(PARMS,$C(28)) D Q:$G(BMXSEC)'=""
. NEW PDATA,NAME,PFIEN,PTYP,FMN
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1)
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S FMN=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
. Q:FMN=""
. S BQICMT(FILE,IENS,FMN)=$G(@NAME)
S BQICMT(FILE,IENS,.04)=$$NOW^XLFDT()
;
XUPDCM I $D(BQICMT) D FILE^DIE("","BQICMT","ERROR")
;
S RESULT=1
I $D(ERROR) S RESULT=-1
S II=II+1,@DATA@(II)=RESULT_"^^"_BQIIEN_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
ADD(BQIDFN,RFFPMT) ; EP - Create new Contraception Methods record
NEW DA,DIC,DLAYGO,IENS,X,Y,DIC,DA,DLAYGO
S DA(1)=BQIDFN,X=RFFPMT
I '$D(^AUPNREP(DA(1),2101,0)) S ^AUPNREP(DA(1),2101,0)="^9000017.02101^^"
S DIC="^AUPNREP("_DA(1)_",2101,",DIC(0)="LMNZ",DLAYGO=9000017.02101,DIC("P")=DLAYGO
K DO,DD D FILE^DICN
Q +Y
;
PFLD(DIEN,CIEN,EDT,FDATA) ;EP - Process one field entry
;
NEW DA,IENS,INACTIVE,CODE,COL,FMN,CEXEC
S DA(1)=DIEN,DA=CIEN,IENS=$$IENS^DILF(.DA)
S INACTIVE=$$GET1^DIQ(90506.31,IENS,.11,"I") Q:INACTIVE
;
;If display mode skip if not Col Type View = Show
I $G(EDT)'=1,$$GET1^DIQ(90506.31,IENS,.12,"I")'="S" Q
S CODE=$$GET1^DIQ(90506.31,IENS,.07,"I") Q:CODE=""
S COL=$$GET1^DIQ(90506.31,IENS,.01,"I") Q:COL=""
S FMN=$$GET1^DIQ(90506.31,IENS,3.01,"I")
S CEXEC=$$GET1^DIQ(90506.31,IENS,8,"I")
;
;Filter EDD fields if in display mode and not pregnant
I $$GET1^DIQ(9000017,DFN_",",1101,"I")'="Y",$G(EDT)'=1,$D(EDFLD(COL)) Q
;
K DA,IENS
NEW DA,IENS,VAL
S DA=DFN,IENS=$$IENS^DILF(.DA)
S VAL=""
S:FMN]"" VAL=$$GET1^DIQ(9000017,IENS,FMN,"E")
;
I CEXEC]"" X CEXEC
;
;Log that a row value was found
I $P(VAL,U)]"" S FDATA=1
;
S II=$G(II)+1,@DATA@(II)=CODE_U_COL_U_$P(VAL,U)_U_$P(VAL,U,2)_U_$P(VAL,U,3)_$C(30)
Q
;
VALS(DFN,VAL,DTCOL,PVCOL) ;EP - Return date and provider values
NEW DTVAL,PVVAL
;
; Check the version of software
I $$VERSION^XPDUTL("IHS PCC SUITE")<2.0 Q $P($G(VAL),U)_"^^"
;
S VAL=$G(VAL,""),DTCOL=$G(DTCOL,""),PVCOL=$G(PVCOL,"")
S (DTVAL,PVVAL)=""
;
;Make sure fields have been loaded (was patch installed?)
I DTCOL]"" S:($$GET1^DID(9000017,DTCOL,"","LABEL")="") DTCOL=""
I PVCOL]"" S:($$GET1^DID(9000017,PVCOL,"","LABEL")="") PVCOL=""
;
I DTCOL]"" S DTVAL=$$FMTE^BQIUL1($$GET1^DIQ(9000017,DFN_",",DTCOL,"I"))
I PVCOL]"" S PVCOL=$$GET1^DIQ(9000017,DFN_",",PVCOL,"I")
S:PVCOL]"" PVVAL=$$GET1^DIQ(200,PVCOL_",",.01,"E")
I $L(VAL,U)>1 S VAL=$P(VAL,U)_U_$P(VAL,U,2)_U_$P(VAL,U,3)
E S VAL=VAL_U_DTVAL_U_PVVAL
Q VAL
;
CONT(DFN) ;EP - Return patients most recent contraceptive method info
;
NEW VALUE
;
I $G(DFN)="" Q ""
;
; Check the version of software
I $$VERSION^XPDUTL("IHS PCC SUITE")<2.0 Q ""
;
; Return single field 3.05 if no patch 7
I '$$PATCH^XPDUTL("BJPC*2.0*7") D Q VALUE
. NEW BGDT,DTLM
. S BGDT=$$FMTE^BQIUL1($$GET1^DIQ(9000017,DFN_",","3.05","I"))
. S DTLM=$$FMTE^BQIUL1($$GET1^DIQ(9000017,DFN_",","3.1","I"))
. S VALUE=$C(28)_BGDT_U_DTLM
;
NEW CONDT,CONIEN,CONMET,CONLMD,DA,IENS,CONUPD
;
S CONDT=$O(^AUPNREP(DFN,2101,"AD",""),-1) Q:CONDT="" ""
S CONIEN=$O(^AUPNREP(DFN,2101,"AD",CONDT,""),-1) Q:CONIEN="" ""
S DA(1)=DFN,DA=CONIEN,IENS=$$IENS^DILF(.DA)
S CONMET=$$GET1^DIQ(9000017.02101,IENS,.01,"E")
S CONLMD=$$FMTE^BQIUL1($P($$GET1^DIQ(9000017.02101,IENS,.02,"I"),"."))
S CONUPD=$$FMTE^BQIUL1($P($$GET1^DIQ(9000017.02101,IENS,.04,"I"),"."))
;
Q CONMET_U_CONUPD_$C(28)_CONLMD_U_CONUPD
;
UVDEF() ;EP - Update Reproductive Factors VDEF
;
NEW BJPC,CMIEN,DA,IENS,ERROR,EDFLD,CLIST,VER
;
;Set up EDD field array
D EDFLD
;
;Make Contraceptive Methods INACTIVE/ACTIVE
S BJPC=$$PATCH^XPDUTL("BJPC*2.0*7")
S CMIEN=$O(^BQI(90506.3,"B","Contraceptive Methods","")) I CMIEN="" S BMXSEC="Contraceptive Methods Definition Issue" Q
S DA=CMIEN,IENS=$$IENS^DILF(.DA)
I BJPC=1 S BQIACT(90506.3,IENS,".03")="@"
E S BQIACT(90506.3,IENS,".03")=1
D FILE^DIE("","BQIACT","ERROR")
K BJPC,CMIEN,DA,IENS,BQIACT,ERROR
;
;Get field list from VDEF
NEW DIEN,CIEN,BQIACT,FIEN,ERROR
S DIEN=$O(^BQI(90506.3,"B","Reproductive Factors","")) I DIEN="" S BMXSEC="Reproductive Factors Definition Issue" Q
S CIEN=0 F S CIEN=$O(^BQI(90506.3,DIEN,10,CIEN)) Q:'CIEN D
. NEW FMN,DA,IENS
. S DA(1)=DIEN,DA=CIEN,IENS=$$IENS^DILF(.DA)
. S FMN=$$GET1^DIQ(90506.31,IENS,3.01,"I") Q:FMN=""
. S CLIST(FMN)=CIEN
;
; Check the version of software
S VER=$$VERSION^XPDUTL("IHS PCC SUITE")
;
I VER<2.0 D
. NEW FMN,BQIACT,ERROR
. S FMN=0 F S FMN=$O(CLIST(FMN)) Q:FMN="" D
.. NEW ACTIVE,CIEN,DA,IENS
.. I ",.01,1,2,3,3.05,4,"[(","_FMN_",") S ACTIVE="@"
.. E S ACTIVE=1
.. S CIEN=$G(CLIST(FMN)) Q:CIEN=""
.. S DA(1)=DIEN,DA=CIEN,IENS=$$IENS^DILF(.DA)
.. S BQIACT(90506.31,IENS,.11)=ACTIVE
. I $D(BQIACT) D FILE^DIE("","BQIACT","ERROR")
;
;Process Version 2.0 and above
I VER>1.0 D
. ;
. ;Make fields Active/Inactive
. S FIEN=0 F S FIEN=$O(^DD(9000017,FIEN)) Q:'FIEN D
.. NEW ACTIVE,CIEN,DA,IENS
.. I $E($$GET1^DID(9000017,FIEN,"","LABEL"),1)="*" S ACTIVE="1"
.. E I $$GET1^DID(9000017,FIEN,"","LABEL")="" S ACTIVE="1"
.. E S ACTIVE="@"
.. S CIEN=$G(CLIST(FIEN)) Q:CIEN=""
.. S DA(1)=DIEN,DA=CIEN,IENS=$$IENS^DILF(.DA)
.. S BQIACT(90506.31,IENS,.11)=ACTIVE
.. K CLIST(FIEN)
. ;
. ;Make any remaining fields Inactive
. S FIEN="" F S FIEN=$O(CLIST(FIEN)) Q:'FIEN D
.. NEW CIEN,DA,IENS
.. S CIEN=$G(CLIST(FIEN)) Q:CIEN=""
.. S DA(1)=DIEN,DA=CIEN,IENS=$$IENS^DILF(.DA)
.. S BQIACT(90506.31,IENS,.11)=1
.. K CLIST(FIEN)
. ;
. ;Special Contraceptive/Family Planning Method/Contraception Begun field handling
. D
.. NEW CIEN,DA,IENS
.. S CIEN=$O(^BQI(90506.3,DIEN,10,"B","Current Family Planning Method","")) Q:CIEN=""
.. S DA(1)=DIEN,DA=CIEN,IENS=$$IENS^DILF(.DA)
.. I $$PATCH^XPDUTL("BJPC*2.0*7") S BQIACT(90506.31,IENS,.11)=1 Q
.. S BQIACT(90506.31,IENS,.11)="@"
. D
.. NEW CIEN,DA,IENS
.. S CIEN=$O(^BQI(90506.3,DIEN,10,"B","Current Contraceptive Method","")) Q:CIEN=""
.. S DA(1)=DIEN,DA=CIEN,IENS=$$IENS^DILF(.DA)
.. I $$PATCH^XPDUTL("BJPC*2.0*7") S BQIACT(90506.31,IENS,.11)="@" Q
.. S BQIACT(90506.31,IENS,.11)="1"
. ;
. D
.. NEW CIEN,DA,IENS
.. S CIEN=$O(^BQI(90506.3,DIEN,10,"B","Contraception Begun","")) Q:CIEN=""
.. S DA(1)=DIEN,DA=CIEN,IENS=$$IENS^DILF(.DA)
.. I $$PATCH^XPDUTL("BJPC*2.0*7") S BQIACT(90506.31,IENS,.04)="H" Q
.. S BQIACT(90506.31,IENS,.04)="S"
. ;
. D
.. NEW CIEN,DA,IENS
.. S CIEN=$O(^BQI(90506.3,DIEN,10,"B","EDD Method","")) Q:CIEN=""
.. S DA(1)=DIEN,DA=CIEN,IENS=$$IENS^DILF(.DA)
.. I $$PATCH^XPDUTL("BJPC*2.0*7") S BQIACT(90506.31,IENS,.11)="1" Q
.. S BQIACT(90506.31,IENS,.11)="@"
. ;
. I $D(BQIACT) D FILE^DIE("","BQIACT","ERROR")
Q
;
EDFLD ;EP - Assemble list of EDD fields
;
S EDFLD("Definitive EDD")=""
S EDFLD("EDD (LMP)")=""
S EDFLD("EDD (Ultrasound)")=""
S EDFLD("EDD (Clinical Parameters)")=""
S EDFLD("EDD (Method Unknown)")=""
S EDFLD("Definitive EDD Documenting Provider")=""
S EDFLD("EDD (LMP) Documenting Provider")=""
S EDFLD("EDD (Ultrasound) Documenting Provider")=""
S EDFLD("EDD (Clinical Parms) Documenting Provider")=""
S EDFLD("EDD (Meth Unk) Documenting Provider")=""
Q
;
TRGPRG(DATA,BQICPREG) ; EP - BQI REP FAC PRG TRIG
NEW UID,II,VALUE,SOURCE,HELP,ABLE,REQ,CLEAR,TYPE,CLFLAG
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTRP1",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTRP1 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 BQICPREG=$G(BQICPREG,""),ABLE="Y"
I BQICPREG'="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
BQIPTRP1 ;VNGT/HS/ALA - Patient Reproductive Factors ; 06 May 2008 7:40 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
+2 ;
REP(DATA,DFN,EDT) ; EP -- BQI PATIENT REPRODUCTIVE FACS
+1 ;
+2 ;Description - all the reproductive factors that a patient has
+3 ;
+4 ;Input
+5 ; DFN - Patient internal entry number
+6 ; EDT - 1 - Call was from Edit Load, otherwise Null
+7 ;
+8 NEW UID,II,SEX,AGE,DIEN,DORD,CIEN,CLIST,BQIACT,ERROR,FIEN,VER,EDFLD,FDATA
+9 ;
+10 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+11 SET DATA=$NAME(^TMP("BQIPTRP1",UID))
+12 KILL @DATA
+13 ;
+14 SET II=0
+15 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTRP1 D UNWIND^%ZTER"
+16 ;
+17 SET DIEN=$ORDER(^BQI(90506.3,"B","Reproductive Factors",""))
IF DIEN=""
SET BMXSEC="Reproductive Factors Definition Issue"
QUIT
+18 SET EDT=$GET(EDT,"")
+19 SET SEX=$$GET1^DIQ(2,DFN_",",.02,"I")
SET AGE=$$AGE^BQIAGE(DFN)
+20 IF SEX'="F"
Begin DoDot:1
+21 SET @DATA@(II)="I00010RESULT^T00080MESSAGE"_$CHAR(30)
+22 SET II=II+1
SET @DATA@(II)="-1^RPC Failed: Patient is not Female"_$CHAR(30)
+23 SET II=II+1
SET @DATA@(II)=$CHAR(31)
End DoDot:1
QUIT
+24 ;
+25 SET FDATA=""
+26 SET @DATA@(II)="T00010COLUMN_NAME^T00045COLUMN_DESC^T00120COLUMN_VALUE^D00030DATE_LAST_MODIFIED^T00075PRV_LAST_MODIFIED"_$CHAR(30)
+27 ;
+28 ;Set up EDD field array
+29 DO EDFLD
+30 ;
+31 ;Update VDEF Reproductive Factors entry
+32 DO UVDEF()
+33 ;
+34 ;Loop through GRID ORDER and get each row
+35 SET DORD=""
FOR
SET DORD=$ORDER(^BQI(90506.3,DIEN,10,"AF",DORD))
IF DORD=""
QUIT
SET CIEN=""
FOR
SET CIEN=$ORDER(^BQI(90506.3,DIEN,10,"AF",DORD,CIEN))
IF CIEN=""
QUIT
DO PFLD(DIEN,CIEN,EDT,FDATA)
+36 ;
+37 ;Age check
+38 IF 'FDATA
IF AGE<10
Begin DoDot:1
+39 KILL @DATA
+40 SET @DATA@(II)="I00010RESULT^T00080MESSAGE"_$CHAR(30)
+41 SET II=II+1
SET @DATA@(II)="-1^RPC Failed: Patient is less than 10 years of age"_$CHAR(30)
+42 SET II=II+1
SET @DATA@(II)=$CHAR(31)
End DoDot:1
QUIT
+43 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
CMETH(DATA,DFN) ; EP -- BQI GET PATIENT CON METH
+1 ;
+2 NEW UID,II,HDR,MIEN
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIPTRP1",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTRP1 D UNWIND^%ZTER"
+9 ;
+10 SET HDR="I00010CMIEN^T00050RFFPMT^D00030RFFPBDT^D00030RFFPEDT^T00100RFCMDSC^T00100RFCMCMT^D00030RFCFUPD"
+11 SET @DATA@(II)=HDR_$CHAR(30)
+12 ;
+13 ;Pull Contraception Method Information
+14 SET MIEN=0
FOR
SET MIEN=$ORDER(^AUPNREP(DFN,2101,MIEN))
IF 'MIEN
QUIT
Begin DoDot:1
+15 ;
+16 NEW DA,IENS,METH,XMTH,CBEG,CEND,CDIS,CCOM,CLDT
+17 SET DA(1)=DFN
SET DA=MIEN
SET IENS=$$IENS^DILF(.DA)
+18 SET METH=$$GET1^DIQ(9000017.02101,IENS,.01,"I")
+19 SET XMTH=$$GET1^DIQ(9000017.02101,IENS,.01,"E")
+20 SET CBEG=$$FMTE^BQIUL1($$GET1^DIQ(9000017.02101,IENS,.02,"I"))
+21 SET CEND=$$FMTE^BQIUL1($$GET1^DIQ(9000017.02101,IENS,.03,"I"))
+22 SET CLDT=$$FMTE^BQIUL1($$GET1^DIQ(9000017.02101,IENS,.04,"I"))
+23 SET CDIS=$$GET1^DIQ(9000017.02101,IENS,.05,"E")
+24 SET CCOM=$$GET1^DIQ(9000017.02101,IENS,.06,"E")
+25 SET II=II+1
SET @DATA@(II)=MIEN_U_METH_$CHAR(28)_XMTH_U_CBEG_U_CEND_U_CDIS_U_CCOM_U_CLDT_$CHAR(30)
End DoDot:1
+26 ;
+27 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+28 QUIT
+29 ;
UPDCM(DATA,BQIDFN,BQIIEN,BQIED,PARMS) ; EP - BQI UPD PAT CMETH
+1 ; Input parameters
+2 ; BQIDFN - Patient DFN
+3 ; BQIIEN - Contraception Method Entry IEN
+4 ; BQIED - E for Add/Edit, D for Delete
+5 ; PARMS - Parameters and their values
+6 ;
+7 NEW UID,II,VFIEN,FILE,BQ,RFFPMT,RFFPBDT,RFFPEDT,RFCMDSC,RFCMCMT,RFCFUPD
+8 NEW DA,IENS,BQ,BQICMT,ERROR,RESULT
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BQIPTRP1",UID))
+11 KILL @DATA
+12 ;
+13 SET II=0
+14 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTRP1 D UNWIND^%ZTER"
+15 SET @DATA@(II)="I00010RESULT^T01024MSG^I00010HIDE_CMIEN"_$CHAR(30)
+16 ;
+17 SET BQIIEN=$GET(BQIIEN,"")
+18 SET PARMS=$GET(PARMS,"")
+19 SET RFFPMT=$GET(RFFPMT,"")
SET RFFPBDT=$GET(RFFPBDT,"")
SET RFFPEDT=$GET(RFFPEDT,"")
+20 SET RFCMDSC=$GET(RFCMDSC,"")
SET RFCMCMT=$GET(RFCMCMT,"")
SET RFCFUPD=$GET(RFCFUPD,"")
+21 ;
+22 IF PARMS=""
Begin DoDot:1
+23 NEW LIST,BN
+24 SET LIST=""
SET BN=""
+25 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+26 KILL PARMS
+27 SET PARMS=LIST
+28 KILL LIST
End DoDot:1
+29 ;
+30 SET VFIEN=$ORDER(^BQI(90506.3,"B","Contraceptive Methods",""))
+31 IF VFIEN=""
SET BMXSEC="RPC Call Failed: Contraceptive Methods VDEF does not exist."
QUIT
+32 SET FILE=$PIECE(^BQI(90506.3,VFIEN,0),U,2)
+33 ;
+34 ;Process Deletes
+35 IF BQIED="D"
Begin DoDot:1
+36 NEW DA,IENS
+37 SET DA(1)=BQIDFN
SET DA=BQIIEN
SET IENS=$$IENS^DILF(.DA)
+38 SET BQICMT(FILE,IENS,".01")="@"
End DoDot:1
GOTO XUPDCM
+39 ;
+40 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+41 NEW PDATA,NAME,VALUE,PFIEN,PTYP,CHIEN
+42 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+43 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+44 IF VALUE=""
SET VALUE="@"
+45 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+46 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+47 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+48 IF PTYP="D"
SET VALUE=$$DATE^BQIUL1(VALUE)
+49 IF PTYP="C"
Begin DoDot:2
+50 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+51 SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+52 SET @NAME=VALUE
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+53 ;
+54 IF BQIIEN=""
IF RFFPMT=""
SET BMXSEC="RPC Call Failed: No Contraceptive Method passed in."
QUIT
+55 IF BQIIEN=""
SET BQIIEN=$$ADD(BQIDFN,RFFPMT)
+56 ;
+57 SET DA(1)=BQIDFN
SET DA=BQIIEN
SET IENS=$$IENS^DILF(.DA)
+58 ;
+59 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+60 NEW PDATA,NAME,PFIEN,PTYP,FMN
+61 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+62 SET NAME=$PIECE(PDATA,"=",1)
+63 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+64 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+65 SET FMN=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
+66 IF FMN=""
QUIT
+67 SET BQICMT(FILE,IENS,FMN)=$GET(@NAME)
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+68 SET BQICMT(FILE,IENS,.04)=$$NOW^XLFDT()
+69 ;
XUPDCM IF $DATA(BQICMT)
DO FILE^DIE("","BQICMT","ERROR")
+1 ;
+2 SET RESULT=1
+3 IF $DATA(ERROR)
SET RESULT=-1
+4 SET II=II+1
SET @DATA@(II)=RESULT_"^^"_BQIIEN_$CHAR(30)
+5 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
ADD(BQIDFN,RFFPMT) ; EP - Create new Contraception Methods record
+1 NEW DA,DIC,DLAYGO,IENS,X,Y,DIC,DA,DLAYGO
+2 SET DA(1)=BQIDFN
SET X=RFFPMT
+3 IF '$DATA(^AUPNREP(DA(1),2101,0))
SET ^AUPNREP(DA(1),2101,0)="^9000017.02101^^"
+4 SET DIC="^AUPNREP("_DA(1)_",2101,"
SET DIC(0)="LMNZ"
SET DLAYGO=9000017.02101
SET DIC("P")=DLAYGO
+5 KILL DO,DD
DO FILE^DICN
+6 QUIT +Y
+7 ;
PFLD(DIEN,CIEN,EDT,FDATA) ;EP - Process one field entry
+1 ;
+2 NEW DA,IENS,INACTIVE,CODE,COL,FMN,CEXEC
+3 SET DA(1)=DIEN
SET DA=CIEN
SET IENS=$$IENS^DILF(.DA)
+4 SET INACTIVE=$$GET1^DIQ(90506.31,IENS,.11,"I")
IF INACTIVE
QUIT
+5 ;
+6 ;If display mode skip if not Col Type View = Show
+7 IF $GET(EDT)'=1
IF $$GET1^DIQ(90506.31,IENS,.12,"I")'="S"
QUIT
+8 SET CODE=$$GET1^DIQ(90506.31,IENS,.07,"I")
IF CODE=""
QUIT
+9 SET COL=$$GET1^DIQ(90506.31,IENS,.01,"I")
IF COL=""
QUIT
+10 SET FMN=$$GET1^DIQ(90506.31,IENS,3.01,"I")
+11 SET CEXEC=$$GET1^DIQ(90506.31,IENS,8,"I")
+12 ;
+13 ;Filter EDD fields if in display mode and not pregnant
+14 IF $$GET1^DIQ(9000017,DFN_",",1101,"I")'="Y"
IF $GET(EDT)'=1
IF $DATA(EDFLD(COL))
QUIT
+15 ;
+16 KILL DA,IENS
+17 NEW DA,IENS,VAL
+18 SET DA=DFN
SET IENS=$$IENS^DILF(.DA)
+19 SET VAL=""
+20 IF FMN]""
SET VAL=$$GET1^DIQ(9000017,IENS,FMN,"E")
+21 ;
+22 IF CEXEC]""
XECUTE CEXEC
+23 ;
+24 ;Log that a row value was found
+25 IF $PIECE(VAL,U)]""
SET FDATA=1
+26 ;
+27 SET II=$GET(II)+1
SET @DATA@(II)=CODE_U_COL_U_$PIECE(VAL,U)_U_$PIECE(VAL,U,2)_U_$PIECE(VAL,U,3)_$CHAR(30)
+28 QUIT
+29 ;
VALS(DFN,VAL,DTCOL,PVCOL) ;EP - Return date and provider values
+1 NEW DTVAL,PVVAL
+2 ;
+3 ; Check the version of software
+4 IF $$VERSION^XPDUTL("IHS PCC SUITE")<2.0
QUIT $PIECE($GET(VAL),U)_"^^"
+5 ;
+6 SET VAL=$GET(VAL,"")
SET DTCOL=$GET(DTCOL,"")
SET PVCOL=$GET(PVCOL,"")
+7 SET (DTVAL,PVVAL)=""
+8 ;
+9 ;Make sure fields have been loaded (was patch installed?)
+10 IF DTCOL]""
IF ($$GET1^DID(9000017,DTCOL,"","LABEL")="")
SET DTCOL=""
+11 IF PVCOL]""
IF ($$GET1^DID(9000017,PVCOL,"","LABEL")="")
SET PVCOL=""
+12 ;
+13 IF DTCOL]""
SET DTVAL=$$FMTE^BQIUL1($$GET1^DIQ(9000017,DFN_",",DTCOL,"I"))
+14 IF PVCOL]""
SET PVCOL=$$GET1^DIQ(9000017,DFN_",",PVCOL,"I")
+15 IF PVCOL]""
SET PVVAL=$$GET1^DIQ(200,PVCOL_",",.01,"E")
+16 IF $LENGTH(VAL,U)>1
SET VAL=$PIECE(VAL,U)_U_$PIECE(VAL,U,2)_U_$PIECE(VAL,U,3)
+17 IF '$TEST
SET VAL=VAL_U_DTVAL_U_PVVAL
+18 QUIT VAL
+19 ;
CONT(DFN) ;EP - Return patients most recent contraceptive method info
+1 ;
+2 NEW VALUE
+3 ;
+4 IF $GET(DFN)=""
QUIT ""
+5 ;
+6 ; Check the version of software
+7 IF $$VERSION^XPDUTL("IHS PCC SUITE")<2.0
QUIT ""
+8 ;
+9 ; Return single field 3.05 if no patch 7
+10 IF '$$PATCH^XPDUTL("BJPC*2.0*7")
Begin DoDot:1
+11 NEW BGDT,DTLM
+12 SET BGDT=$$FMTE^BQIUL1($$GET1^DIQ(9000017,DFN_",","3.05","I"))
+13 SET DTLM=$$FMTE^BQIUL1($$GET1^DIQ(9000017,DFN_",","3.1","I"))
+14 SET VALUE=$CHAR(28)_BGDT_U_DTLM
End DoDot:1
QUIT VALUE
+15 ;
+16 NEW CONDT,CONIEN,CONMET,CONLMD,DA,IENS,CONUPD
+17 ;
+18 SET CONDT=$ORDER(^AUPNREP(DFN,2101,"AD",""),-1)
IF CONDT=""
QUIT ""
+19 SET CONIEN=$ORDER(^AUPNREP(DFN,2101,"AD",CONDT,""),-1)
IF CONIEN=""
QUIT ""
+20 SET DA(1)=DFN
SET DA=CONIEN
SET IENS=$$IENS^DILF(.DA)
+21 SET CONMET=$$GET1^DIQ(9000017.02101,IENS,.01,"E")
+22 SET CONLMD=$$FMTE^BQIUL1($PIECE($$GET1^DIQ(9000017.02101,IENS,.02,"I"),"."))
+23 SET CONUPD=$$FMTE^BQIUL1($PIECE($$GET1^DIQ(9000017.02101,IENS,.04,"I"),"."))
+24 ;
+25 QUIT CONMET_U_CONUPD_$CHAR(28)_CONLMD_U_CONUPD
+26 ;
UVDEF() ;EP - Update Reproductive Factors VDEF
+1 ;
+2 NEW BJPC,CMIEN,DA,IENS,ERROR,EDFLD,CLIST,VER
+3 ;
+4 ;Set up EDD field array
+5 DO EDFLD
+6 ;
+7 ;Make Contraceptive Methods INACTIVE/ACTIVE
+8 SET BJPC=$$PATCH^XPDUTL("BJPC*2.0*7")
+9 SET CMIEN=$ORDER(^BQI(90506.3,"B","Contraceptive Methods",""))
IF CMIEN=""
SET BMXSEC="Contraceptive Methods Definition Issue"
QUIT
+10 SET DA=CMIEN
SET IENS=$$IENS^DILF(.DA)
+11 IF BJPC=1
SET BQIACT(90506.3,IENS,".03")="@"
+12 IF '$TEST
SET BQIACT(90506.3,IENS,".03")=1
+13 DO FILE^DIE("","BQIACT","ERROR")
+14 KILL BJPC,CMIEN,DA,IENS,BQIACT,ERROR
+15 ;
+16 ;Get field list from VDEF
+17 NEW DIEN,CIEN,BQIACT,FIEN,ERROR
+18 SET DIEN=$ORDER(^BQI(90506.3,"B","Reproductive Factors",""))
IF DIEN=""
SET BMXSEC="Reproductive Factors Definition Issue"
QUIT
+19 SET CIEN=0
FOR
SET CIEN=$ORDER(^BQI(90506.3,DIEN,10,CIEN))
IF 'CIEN
QUIT
Begin DoDot:1
+20 NEW FMN,DA,IENS
+21 SET DA(1)=DIEN
SET DA=CIEN
SET IENS=$$IENS^DILF(.DA)
+22 SET FMN=$$GET1^DIQ(90506.31,IENS,3.01,"I")
IF FMN=""
QUIT
+23 SET CLIST(FMN)=CIEN
End DoDot:1
+24 ;
+25 ; Check the version of software
+26 SET VER=$$VERSION^XPDUTL("IHS PCC SUITE")
+27 ;
+28 IF VER<2.0
Begin DoDot:1
+29 NEW FMN,BQIACT,ERROR
+30 SET FMN=0
FOR
SET FMN=$ORDER(CLIST(FMN))
IF FMN=""
QUIT
Begin DoDot:2
+31 NEW ACTIVE,CIEN,DA,IENS
+32 IF ",.01,1,2,3,3.05,4,"[(","_FMN_",")
SET ACTIVE="@"
+33 IF '$TEST
SET ACTIVE=1
+34 SET CIEN=$GET(CLIST(FMN))
IF CIEN=""
QUIT
+35 SET DA(1)=DIEN
SET DA=CIEN
SET IENS=$$IENS^DILF(.DA)
+36 SET BQIACT(90506.31,IENS,.11)=ACTIVE
End DoDot:2
+37 IF $DATA(BQIACT)
DO FILE^DIE("","BQIACT","ERROR")
End DoDot:1
+38 ;
+39 ;Process Version 2.0 and above
+40 IF VER>1.0
Begin DoDot:1
+41 ;
+42 ;Make fields Active/Inactive
+43 SET FIEN=0
FOR
SET FIEN=$ORDER(^DD(9000017,FIEN))
IF 'FIEN
QUIT
Begin DoDot:2
+44 NEW ACTIVE,CIEN,DA,IENS
+45 IF $EXTRACT($$GET1^DID(9000017,FIEN,"","LABEL"),1)="*"
SET ACTIVE="1"
+46 IF '$TEST
IF $$GET1^DID(9000017,FIEN,"","LABEL")=""
SET ACTIVE="1"
+47 IF '$TEST
SET ACTIVE="@"
+48 SET CIEN=$GET(CLIST(FIEN))
IF CIEN=""
QUIT
+49 SET DA(1)=DIEN
SET DA=CIEN
SET IENS=$$IENS^DILF(.DA)
+50 SET BQIACT(90506.31,IENS,.11)=ACTIVE
+51 KILL CLIST(FIEN)
End DoDot:2
+52 ;
+53 ;Make any remaining fields Inactive
+54 SET FIEN=""
FOR
SET FIEN=$ORDER(CLIST(FIEN))
IF 'FIEN
QUIT
Begin DoDot:2
+55 NEW CIEN,DA,IENS
+56 SET CIEN=$GET(CLIST(FIEN))
IF CIEN=""
QUIT
+57 SET DA(1)=DIEN
SET DA=CIEN
SET IENS=$$IENS^DILF(.DA)
+58 SET BQIACT(90506.31,IENS,.11)=1
+59 KILL CLIST(FIEN)
End DoDot:2
+60 ;
+61 ;Special Contraceptive/Family Planning Method/Contraception Begun field handling
+62 Begin DoDot:2
+63 NEW CIEN,DA,IENS
+64 SET CIEN=$ORDER(^BQI(90506.3,DIEN,10,"B","Current Family Planning Method",""))
IF CIEN=""
QUIT
+65 SET DA(1)=DIEN
SET DA=CIEN
SET IENS=$$IENS^DILF(.DA)
+66 IF $$PATCH^XPDUTL("BJPC*2.0*7")
SET BQIACT(90506.31,IENS,.11)=1
QUIT
+67 SET BQIACT(90506.31,IENS,.11)="@"
End DoDot:2
+68 Begin DoDot:2
+69 NEW CIEN,DA,IENS
+70 SET CIEN=$ORDER(^BQI(90506.3,DIEN,10,"B","Current Contraceptive Method",""))
IF CIEN=""
QUIT
+71 SET DA(1)=DIEN
SET DA=CIEN
SET IENS=$$IENS^DILF(.DA)
+72 IF $$PATCH^XPDUTL("BJPC*2.0*7")
SET BQIACT(90506.31,IENS,.11)="@"
QUIT
+73 SET BQIACT(90506.31,IENS,.11)="1"
End DoDot:2
+74 ;
+75 Begin DoDot:2
+76 NEW CIEN,DA,IENS
+77 SET CIEN=$ORDER(^BQI(90506.3,DIEN,10,"B","Contraception Begun",""))
IF CIEN=""
QUIT
+78 SET DA(1)=DIEN
SET DA=CIEN
SET IENS=$$IENS^DILF(.DA)
+79 IF $$PATCH^XPDUTL("BJPC*2.0*7")
SET BQIACT(90506.31,IENS,.04)="H"
QUIT
+80 SET BQIACT(90506.31,IENS,.04)="S"
End DoDot:2
+81 ;
+82 Begin DoDot:2
+83 NEW CIEN,DA,IENS
+84 SET CIEN=$ORDER(^BQI(90506.3,DIEN,10,"B","EDD Method",""))
IF CIEN=""
QUIT
+85 SET DA(1)=DIEN
SET DA=CIEN
SET IENS=$$IENS^DILF(.DA)
+86 IF $$PATCH^XPDUTL("BJPC*2.0*7")
SET BQIACT(90506.31,IENS,.11)="1"
QUIT
+87 SET BQIACT(90506.31,IENS,.11)="@"
End DoDot:2
+88 ;
+89 IF $DATA(BQIACT)
DO FILE^DIE("","BQIACT","ERROR")
End DoDot:1
+90 QUIT
+91 ;
EDFLD ;EP - Assemble list of EDD fields
+1 ;
+2 SET EDFLD("Definitive EDD")=""
+3 SET EDFLD("EDD (LMP)")=""
+4 SET EDFLD("EDD (Ultrasound)")=""
+5 SET EDFLD("EDD (Clinical Parameters)")=""
+6 SET EDFLD("EDD (Method Unknown)")=""
+7 SET EDFLD("Definitive EDD Documenting Provider")=""
+8 SET EDFLD("EDD (LMP) Documenting Provider")=""
+9 SET EDFLD("EDD (Ultrasound) Documenting Provider")=""
+10 SET EDFLD("EDD (Clinical Parms) Documenting Provider")=""
+11 SET EDFLD("EDD (Meth Unk) Documenting Provider")=""
+12 QUIT
+13 ;
TRGPRG(DATA,BQICPREG) ; EP - BQI REP FAC PRG TRIG
+1 NEW UID,II,VALUE,SOURCE,HELP,ABLE,REQ,CLEAR,TYPE,CLFLAG
+2 ;
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIPTRP1",UID))
+5 KILL @DATA
+6 SET II=0
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTRP1 D UNWIND^%ZTER"
+8 ;
+9 ;Define Header
+10 SET @DATA@(II)="T00008SOURCE^T00001CODE_TYPE^T01024PARMS^T00030PROP_VALUE^T00001ABLE_FLAG^T00001REQ_OPT^T00200HELP_TEXT^T01024CLEAR_FIELDS^T00001CLEAR_FLAG"_$CHAR(30)
+11 ;
+12 SET BQICPREG=$GET(BQICPREG,"")
SET ABLE="Y"
+13 IF BQICPREG'="Y"
SET ABLE="N"
+14 SET SOURCE="RFDFEDD"
SET VALUE=""
SET HELP=""
SET REQ=""
SET CLEAR=""
SET CLFLAG="N"
SET TYPE="C"
DO REC
+15 SET SOURCE="RFEDDLMP"
SET VALUE=""
SET HELP=""
SET REQ=""
SET CLEAR=""
SET CLFLAG="N"
SET TYPE="C"
DO REC
+16 SET SOURCE="RFEDDULT"
SET VALUE=""
SET HELP=""
SET REQ=""
SET CLEAR=""
SET CLFLAG="N"
SET TYPE="C"
DO REC
+17 SET SOURCE="RFEDDCLP"
SET VALUE=""
SET HELP=""
SET REQ=""
SET CLEAR=""
SET CLFLAG="N"
SET TYPE="C"
DO REC
+18 SET SOURCE="RFEDDUNK"
SET VALUE=""
SET HELP=""
SET REQ=""
SET CLEAR=""
SET CLFLAG="N"
SET TYPE="C"
DO REC
+19 SET SOURCE="RFEDDDPV"
SET VALUE=""
SET HELP=""
SET REQ=""
SET CLEAR=""
SET CLFLAG="N"
SET TYPE="C"
DO REC
+20 SET SOURCE="RFEDDLPV"
SET VALUE=""
SET HELP=""
SET REQ=""
SET CLEAR=""
SET CLFLAG="N"
SET TYPE="C"
DO REC
+21 SET SOURCE="RFEDDUPV"
SET VALUE=""
SET HELP=""
SET REQ=""
SET CLEAR=""
SET CLFLAG="N"
SET TYPE="C"
DO REC
+22 SET SOURCE="RFEDDCPV"
SET VALUE=""
SET HELP=""
SET REQ=""
SET CLEAR=""
SET CLFLAG="N"
SET TYPE="C"
DO REC
+23 SET SOURCE="RFEDDMPV"
SET VALUE=""
SET HELP=""
SET REQ=""
SET CLEAR=""
SET CLFLAG="N"
SET TYPE="C"
DO REC
+24 ;
+25 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+26 QUIT
+27 ;
+28 ;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
