BGOREP ; IHS/BAO/TMD - Manage REPRODUCTIVE FACTORS ;21-Mar-2016 11:12;DU
;;1.1;BGO COMPONENTS;**1,3,5,6,10,11,14,15,20**;Mar 20, 2007;Build 6
; Returns reproductive history as a single string
; Patch 5 updates the expanded history logic to prevent error on an empty element.
; Patch 6 updates to use new field formats for repro history
; Patch 20 fix for deleting EDD field
TIUSTR() ;EP
N X
Q:'$G(DFN) ""
D GET(.X,DFN)
Q X
; Get reproductive factors on patient
; Returned as a list of data elements
; INP = Patient IEN [1] ^ Date Obtained (opt) [2] ^ Expand History (opt) [3]
; .RET =
; "L" [1] ^ LMP Date [2] ^ Date Changed [3]
; "C" [1] ^ Contraception Method;Contraception Begun [2]^....(MULTIPLE)
; "P" [1] ^ Pregnant [2] ^ Preg Provider [3] ^Date updated [4]
; "R" [1] ^ Gravida[2] ^ Date[3] ^ Multiple Births[4] ^ Date[5] ^ Full term[6] ^ Date[7] ^ Premature[8]
; ^ Date[9] ^ Ectopics[10] ^ Date[11] ^ Living Children[12] ^ Date[13] ^ Spontaneous abortions[14] ^ Date[15]^Theraputic abortions[16]^Date[17]
; "B" [1] ^ Lactation Status [2] ^ Provider [3] ^ Date changed [4]
; "M" [1] ^ Menarche Age [2] ^ Coitarche Age [3] ^ Menopause age [4]
; "D" [1] ^ DES Daugher [2] ^ Date updated [3]
; "E" [1] ^ EDD def [2] ^ EDD Def prov [3] ^ EDD Def Dt [4] ^ EDD Def Comment [5] ^ EDD LMP [6] ^ EDD LMP prov [7] ^ EDD LMP Date [8]^ EDD LMP Comment [9]
; ^ EDD ult [10] ^EDD Ult Prov [11] ^EDD ult Date [12] ^ EDD Ult Comment [13]
; ^ EDD Clin [14] ^ EDD Clin prov [15] ^ EDD Clin Date [16] ^EDD Clin Comment [17] ^ EDD unknown [18] ^EDD Unknown prov [19] ^EDD unknown date [20] ^ EDD unknown comment [21]
GET(RET,INP) ;EP
N DFN,REC,HX,LMP,LMPDT,BEG,REPC,CONT,DELDT,METHOD,DAT,FNUM,EXP,CNT,REP,PREG,STR
N X,Y,Z,G,M,F,P,E,L,T,S,GD,MD,FD,PD,ED,LD,TD,SD,REPDT,ARRAY
S RET=$$TMPGBL^BGOUTL
S FNUM=$$FNUM
S CNT=0
S DFN=+INP
Q:'DFN
Q:'$D(^AUPNREP(DFN))
S DAT=$P(INP,U,2)
S EXP=$P(INP,U,3)
S REC=$G(^AUPNREP(DFN,0))
D GETDATA
S CNT=CNT+1
S @RET@(CNT)="L"_U_LMP_U_LMPDT
S CNT=CNT+1
I EXP=1 D
. S STR="Total # of pregnancies="_G_U_GD_U_"Multiple Births="_M_U_MD_U_"Full Term="_F_U_FD_U_"Premature="_P_U_PD_U
. S STR=STR_"Ectopic Pregnancies="_E_U_ED_U_"Living Children="_L_U_LD_U_"Spontaneous Abortions (Miscarriages)="_S_U_SD_U_"Induced Abortions="_T_U_TD
. S @RET@(CNT)="R"_U_STR
E S @RET@(CNT)="R"_U_G_U_GD_U_M_U_MD_U_F_U_FD_U_P_U_PD_U_E_U_ED_U_L_U_LD_U_S_U_SD_U_T_U_TD
D LAC^BGOREP1(.RET,.CNT,DFN) ;Get lactation data
D CONT^BGOREP1(.RET,.CNT,DFN) ;Get contraceptive data
D MEN^BGOREP1(.RET,.CNT,DFN) ;Get menstrual data
D EDD^BGOREP1(.RET,.CNT,DFN) ;Get EDD data
;I DAT,$P(REC,U,3)'=DAT S HX=""
GETDATA ;Get the data needed for the repro history
S LMP=$P(REC,U,4)
I DAT'="",$P(REC,U,5)'=DAT S LMP=""
S LMP=$$FMTDATE^BGOUTL(LMP)
S LMPDT=$P(REC,U,5)
S LMPDT=$$FMTDATE^BGOUTL(LMPDT)
S REC=$G(^AUPNREP(DFN,11))
D CHECK(REC)
Q
; Add/edit reproductive factor
;INP=dfn of patient
;DATA is an array
;DATA(1)=L [1] ^ LMP [2] ^ DATE updated [3]
;DATA(2)=R [1] ^ Gravida [2]^ Date Updated [3] ^Multiple Births [4] ^ Date Updated [5] ^Full term [6] ^ Date Updated [7] ^Premature [8]
;^ Date Updated [9] ^Ectopics [10] ^ Date Updated [11] ^Living Children [12] ^ Date Updated [13] ^ Spontaneous abortions [14] ^ SA dt update[15]
;^ Induced abortions [16] ^ TA dt updated [17]
;DATA(3)=M [1] ^ Menarche age [2] ^Dte updated [3] ^coitarche age [4] ^date updated [5] ^menopause age [6] ^date updated [7] ^DES [8] ^Des updated [9]
;DATA(4)=E [1]^ PREGNANT [2]^ Dt updated [3] ^ Pregnant updated prov [4]
;^EDD LMP [5] ^ EDD LMP DT [6] ^ EDD LMP Prov [7] ^ EDD LMP COMMENT [8]
;^EDD ult [9] ^EDD ul dte [10] ^EDD ult prov [11] ^ EDD ult comment [12]
;^EDD Clin [13] ^ EDD Clin dte [14] ^ EDD Clin Prov [15] ^ EDD clin Comment [16
;^EDD unknown [17] ^EDD Unk dte [18] ^ EDD unk prv [19] ^ EDD unk comment [20]
;^EDD Def [21] ^ EDD Def Dte [22] ^EDD Def prov [23] ^ EDD Def Comment [24]
;DATA(5)="B [1] ^lac status [2] ^dt updated [3] ^prov update [4]
SET(RET,INP,DATA) ;EP
N DFN,FNUM,REPHX,LMP,TXT,FP,ARRAY,FPDATE,IDX,PREG,DELIVDT,DELMETH,FDA,IENS,NEW,EDDTX
N EDC,EDCBY,GRAV,GRAVDT,MB,MBDT,FT,FTDT,PRE,PREDT,EC,ECDT,LC,LCDT,SA,SADT,TA,TADT
N DEDD,DEDDP,DEDDT,TODAY,TYPE,PRV
S PRV=$P($G(^VA(200,DUZ,0)),U,1)
S RET="",FNUM=$$FNUM
S TODAY=$$DT^XLFDT
S DFN=+INP
I '$D(^DPT(DFN,0)) S RET=$$ERR^BGOUTL(1001) Q
I $P(^DPT(DFN,0),U,2)'="F" S RET=$$ERR^BGOUTL(1052) Q
S NEW='$D(^AUPNREP(DFN))
S IENS=$S('NEW:DFN_",",1:"+1,")
S FDA=$NA(FDA(FNUM,IENS))
S:NEW @FDA@(.01)="`"_DFN
S @FDA@(1.1)=TODAY
S (IDX,EDDTX)=""
F S IDX=$O(DATA(IDX)) Q:'IDX D
.S TYPE=$P(DATA(IDX),U,1)
.S TXT=$G(DATA(IDX))
.I TYPE="B" D LAC(TXT)
.I TYPE="L" D LMP(TXT)
.I TYPE="R" D REP(TXT)
.I TYPE="M" D MEN(TXT)
.I TYPE="E" D EDD(TXT)
I NEW D
.S RET=$$UPDATE^BGOUTL(.FDA,"E")
E D
.N ERR
.D FILE^DIE("E","FDA","ERR")
.I $D(ERR("DIERR")) S RET=ERR("DIERR")
D:'RET EVT(DFN,'NEW)
;I 'RET D STORE(EDDTX)
K ERR
D STORE(EDDTX)
S:'RET RET=DFN
Q
LMP(TXT) ;Store LMP data
N LMP,LMPUP
S LMP=$P(TXT,U,2)
S LMPUP=$P(TXT,U,3)
I LMPUP="" S LMPUP=$$EXTERNAL^DILFD(TODAY)
I LMP'="" D
.S @FDA@(2)=LMP
.S @FDA@(2.1)=LMPUP
Q
LAC(TXT) ;Store lactation data
N LAC,LACUP,LACPR
S LAC=$$UP^XLFSTR($P(TXT,U,2))
S LACUP=$P(TXT,U,3)
I LACUP="" S LACUP=$$EXTERNAL^DILFD(TODAY)
S LACPR=$P(TXT,U,4)
I LACPR="" S LACPR=PRV
I $L(LAC) D
.S @FDA@(2.01)=LAC
.S:$L(LACPR) @FDA@(2.03)=LACPR
.S:$L(LACUP) @FDA@(2.02)=LACUP
Q
REP(INP) ;Store reproductive history data
S GRAV=$P(INP,U,2),GRAVDT=$P(INP,U,3)
I GRAV'="" D
.S:$L(GRAV) @FDA@(1103)=GRAV
.I $L(GRAVDT) S @FDA@(1104)=GRAVDT
.E S @FDA@(1104)=$$EXTERNAL^DILFD(TODAY)
S MB=$P(INP,U,4),MBDT=$P(INP,U,5)
I MB'="" D
.S:$L(MB) @FDA@(1105)=MB
.I $L(MBDT) S @FDA@(1106)=MBDT
.E S @FDA@(1106)=$$EXTERNAL^DILFD(TODAY)
S FT=$P(INP,U,6),FTDT=$P(INP,U,7)
I FT'="" D
.S:$L(FT) @FDA@(1107)=FT
.I $L(FTDT) S @FDA@(1108)=FTDT
.E S @FDA@(1108)=$$EXTERNAL^DILFD(TODAY)
S PRE=$P(INP,U,8),PREDT=$P(INP,U,9)
I PRE'="" D
.S:$L(PRE) @FDA@(1109)=PRE
.I $L(PREDT) S @FDA@(1110)=PREDT
.E S @FDA@(1110)=$$EXTERNAL^DILFD(TODAY)
S EC=$P(INP,U,10),ECDT=$P(INP,U,11)
I EC'="" D
.S:$L(EC) @FDA@(1111)=EC
.I $L(ECDT) S @FDA@(1112)=ECDT
.E S @FDA@(1112)=$$EXTERNAL^DILFD(TODAY)
S LC=$P(INP,U,12),LCDT=$P(INP,U,13)
I LC'="" D
.S:$L(LC) @FDA@(1113)=LC
.I $L(LCDT) S @FDA@(1114)=LCDT
.E S @FDA@(1114)=$$EXTERNAL^DILFD(TODAY)
S SA=$P(INP,U,14),SADT=$P(INP,U,15)
I SA'="" D
.S:$L(SA) @FDA@(1133)=SA
.I $L(SADT) S @FDA@(1134)=SADT
.E S @FDA@(1134)=$$EXTERNAL^DILFD(TODAY)
S TA=$P(INP,U,16),TADT=$P(INP,U,17)
I TA'="" D
.S:$L(TA) @FDA@(1131)=TA
.I $L(TADT) S @FDA@(1132)=TADT
.E S @FDA@(1132)=$$EXTERNAL^DILFD(TODAY)
Q
MEN(TXT) ;Store menstrual history data
N MAGE,CAGE,MENO,DES,MDT,CDT,MENODT,DESDT
S MAGE=$P(TXT,U,2),MDT=$P(TXT,U,3)
I MAGE="" S MAGE="@"
S:$L(MAGE) @FDA@(1117)=MAGE
I $L(MDT) S @FDA@(1118)=MDT
E S @FDA@(1118)=$$EXTERNAL^DILFD(TODAY)
S CAGE=$P(TXT,U,4),CDT=$P(TXT,U,5)
I CAGE="" S CAGE="@"
S:$L(CAGE) @FDA@(1119)=CAGE
I $L(CDT) S @FDA@(1120)=CDT
E S @FDA@(1120)=$$EXTERNAL^DILFD(TODAY)
S MENO=$P(TXT,U,6),MENODT=$P(TXT,U,7)
I MENO="" S MENO="@"
S:$L(MENO) @FDA@(1121)=MENO
I $L(MENODT) S @FDA@(1122)=MENODT
E S @FDA@(1122)=$$EXTERNAL^DILFD(TODAY)
S DES=$P(TXT,U,8),DESDT=$P(TXT,U,9)
I DES'="" D
.S:$L(DES) @FDA@(1127)=DES
.I $L(DESDT) S @FDA@(1128)=DESDT
.E S @FDA@(1128)=$$EXTERNAL^DILFD(TODAY)
Q
EDD(TXT) ;Get EDD data string and save
S EDDTX=TXT
Q
STORE(TXT) ;Store EDD data string
N EDD,EDDP,EDDT,PREG,PREGPR,PREGDT,FDA,IENS,FNUM,EDDCO
K FDA
Q:TXT=""
S FNUM=$$FNUM
S IENS=DFN_","
S FDA=$NA(FDA(FNUM,IENS))
S PREG=$P(TXT,U,2),PREGPR=$P(TXT,U,3),PREGDT=$P(TXT,U,4) ;Pregnancy data
S PREG=$$UPPER(PREG)
I PREGPR="" S PREGPR=PRV
I PREG'="" D
.S:$L(PREG) @FDA@(1101)=PREG
.S:$L(PREGPR) @FDA@(1135)=PREGPR
.I $L(PREGDT) S @FDA@(1102)=PREGDT
.E S @FDA@(1102)=$$EXTERNAL^DILFD(TODAY)
S EDD=$P(TXT,U,5),EDDP=$P(TXT,U,7),EDDT=$P(TXT,U,6),EDDCO=$P(TXT,U,8) ;EDD by LMP data
I EDDP="" S EDDP=PRV
I PREG="NO"!(PREG="No") S (EDD,EDDP,EDDT,EDDCO)="@"
I EDD'="" D
.S:$L(EDD) @FDA@(1302)=EDD
.S:$L(EDDP) @FDA@(1304)=EDDP
.I $L(EDDT) S @FDA@(1303)=EDDT
.E S @FDA@(1303)=$$EXTERNAL^DILFD(TODAY)
.I $L(EDDCO) S @FDA@(1401)=EDDCO
D FILE^DIE("E","FDA","ERR")
I $D(ERR("DIERR")) S RET=ERR("DIERR")
K FDA,ERR
S FDA=$NA(FDA(FNUM,IENS))
S EDD=$P(TXT,U,9),EDDP=$P(TXT,U,11),EDDT=$P(TXT,U,10),EDDCO=$P(TXT,U,12) ;EDD by ultrasound data
I PREG="NO"!(PREG="No") S (EDD,EDDP,EDDT,EDDCO)="@"
I EDDP="" S EDDP=PRV
I EDD'="" D
.S:$L(EDD) @FDA@(1305)=EDD
.S:$L(EDD) @FDA@(1307)=EDDP
.I $L(EDDT) S @FDA@(1306)=EDDT
.E S @FDA@(1306)=$$EXTERNAL^DILFD(TODAY)
.I $L(EDDCO) S @FDA@(1402)=EDDCO
.D FILE^DIE("E","FDA","ERR")
I $D(ERR("DIERR")) S RET=ERR("DIERR")
K FDA,ERR
S FDA=$NA(FDA(FNUM,IENS))
S EDD=$P(TXT,U,13),EDDP=$P(TXT,U,15),EDDT=$P(TXT,U,14),EDDCO=$P(TXT,U,16) ;EDD by clinical parameters data
I PREG="NO"!(PREG="No") S (EDD,EDDP,EDDT,EDDCO)="@"
I EDDP="" S EDDP=PRV
I EDD'="" D
.S:$L(EDD) @FDA@(1308)=EDD
.S:$L(EDD) @FDA@(1310)=EDDP
.I $L(EDDT) S @FDA@(1309)=EDDT
.E S @FDA@(1309)=$$EXTERNAL^DILFD(TODAY)
.I $L(EDDCO) S @FDA@(1501)=EDDCO
.D FILE^DIE("E","FDA","ERR")
I $D(ERR("DIERR")) S RET=ERR("DIERR")
K FDA,ERR
S FDA=$NA(FDA(FNUM,IENS))
S EDD=$P(TXT,U,17),EDDP=$P(TXT,U,19),EDDT=$P(TXT,U,18),EDDCO=$P(TXT,U,20) ;EDD by known method data
I PREG="NO"!(PREG="No") S (EDD,EDDP,EDDT,EDDCO)="@"
I EDDP="" S EDDP=PRV
I EDD'="" D
.S:$L(EDD) @FDA@(1314)=EDD
.S:$L(EDD) @FDA@(1316)=EDDP
.I $L(EDDT) S @FDA@(1315)=EDDT
.E S @FDA@(1315)=$$EXTERNAL^DILFD(TODAY)
.I $L(EDDCO) S @FDA@(1601)=EDDCO
.D FILE^DIE("E","FDA","ERR")
I $D(ERR("DIERR")) S RET=ERR("DIERR")
S DEDD=$P(TXT,U,21),DEDDP=$P(TXT,U,23),DEDDT=$P(TXT,U,22),EDDCO=$P(TXT,U,24)
K FDA,ERR
S FDA=$NA(FDA(FNUM,IENS))
I PREG="NO"!(PREG="No") S (DEDD,DEDDP,DEDDT,EDDCO)="@"
I DEDDP="" S DEDDP=PRV
I DEDD'="" D
.S:$L(DEDD) @FDA@(1311)=DEDD
.S:$L(DEDD) @FDA@(1313)=DEDDP
.I $L(DEDDT) S @FDA@(1312)=DEDDT
.E S @FDA@(1312)=$$EXTERNAL^DILFD(TODAY)
.I $L(EDDCO) S @FDA@(1502)=EDDCO
.D FILE^DIE("E","FDA","ERR")
I $D(ERR("DIERR")) S RET=ERR("DIERR")
Q
; Delete reproductive history
; DFN = Patient IEN
DEL(RET,DFN) ;EP
S RET=$$DELETE^BGOUTL("^AUPNREP(",DFN)
D:'RET EVT(DFN,2)
Q
; Fire file update events
; IEN = File IEN ( = patient IEN)
; OPR = Operation (0 = add, 1 = edit, 2 = delete)
EVT(IEN,OPR) ;EP
N DATA
S DATA=IEN_U_$G(CIA("UID"))_U_OPR_U_IEN
D BRDCAST^CIANBEVT("PCC."_IEN_".REP",DATA)
Q
; Expand reproductive history
EXPHX(DFN) ;
N REC,HX,LMP,BEG,REPC,CONT,DELDT,METHOD,FNUM,EXP,CNT,REP,PREG,STR
N X,Y,Z,G,M,F,P,E,L,T,S,GD,MD,FD,PD,ED,LD,TD,SD,REPDT,X2,TRGSTR
S TRGSTR=""
Q:'DFN
Q:'$D(^AUPNREP(DFN))
S FNUM=$$FNUM
S REC=$G(^AUPNREP(DFN,0))
D GETDATA
S STR="Total Preg="_G_";Multiple Births="_M_";Full Term="_F_";Premature="_P
S STR=STR_";Ectopics="_E_";Living="_L_";SponAb="_S_";TxAb="_T
S TRGSTR=STR
Q TRGSTR
CHECK(REP) ;Get the different reproductive elements
S REPDT=$P(REP,U,30)
S REPDT=$$FMTDATE^BGOUTL(REPDT)
S G=$P(REP,U,3),GD=$$FMTDATE^BGOUTL($P(REP,U,4))
I G="" S G=0
S M=$P(REP,U,5),MD=$$FMTDATE^BGOUTL($P(REP,U,6))
S F=$P(REP,U,7),FD=$$FMTDATE^BGOUTL($P(REP,U,8))
S P=$P(REP,U,9),PD=$$FMTDATE^BGOUTL($P(REP,U,10))
S E=$P(REP,U,11),ED=$$FMTDATE^BGOUTL($P(REP,U,12))
S L=$P(REP,U,13),LD=$$FMTDATE^BGOUTL($P(REP,U,14))
S T=$P(REP,U,31),TD=$$FMTDATE^BGOUTL($P(REP,U,32))
S S=$P(REP,U,33),SD=$$FMTDATE^BGOUTL($P(REP,U,34))
Q
UPPER(X) ;Turn value to upper case
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
; Return file number
FNUM() Q 9000017
BGOREP ; IHS/BAO/TMD - Manage REPRODUCTIVE FACTORS ;21-Mar-2016 11:12;DU
+1 ;;1.1;BGO COMPONENTS;**1,3,5,6,10,11,14,15,20**;Mar 20, 2007;Build 6
+2 ; Returns reproductive history as a single string
+3 ; Patch 5 updates the expanded history logic to prevent error on an empty element.
+4 ; Patch 6 updates to use new field formats for repro history
+5 ; Patch 20 fix for deleting EDD field
TIUSTR() ;EP
+1 NEW X
+2 IF '$GET(DFN)
QUIT ""
+3 DO GET(.X,DFN)
+4 QUIT X
+5 ; Get reproductive factors on patient
+6 ; Returned as a list of data elements
+7 ; INP = Patient IEN [1] ^ Date Obtained (opt) [2] ^ Expand History (opt) [3]
+8 ; .RET =
+9 ; "L" [1] ^ LMP Date [2] ^ Date Changed [3]
+10 ; "C" [1] ^ Contraception Method;Contraception Begun [2]^....(MULTIPLE)
+11 ; "P" [1] ^ Pregnant [2] ^ Preg Provider [3] ^Date updated [4]
+12 ; "R" [1] ^ Gravida[2] ^ Date[3] ^ Multiple Births[4] ^ Date[5] ^ Full term[6] ^ Date[7] ^ Premature[8]
+13 ; ^ Date[9] ^ Ectopics[10] ^ Date[11] ^ Living Children[12] ^ Date[13] ^ Spontaneous abortions[14] ^ Date[15]^Theraputic abortions[16]^Date[17]
+14 ; "B" [1] ^ Lactation Status [2] ^ Provider [3] ^ Date changed [4]
+15 ; "M" [1] ^ Menarche Age [2] ^ Coitarche Age [3] ^ Menopause age [4]
+16 ; "D" [1] ^ DES Daugher [2] ^ Date updated [3]
+17 ; "E" [1] ^ EDD def [2] ^ EDD Def prov [3] ^ EDD Def Dt [4] ^ EDD Def Comment [5] ^ EDD LMP [6] ^ EDD LMP prov [7] ^ EDD LMP Date [8]^ EDD LMP Comment [9]
+18 ; ^ EDD ult [10] ^EDD Ult Prov [11] ^EDD ult Date [12] ^ EDD Ult Comment [13]
+19 ; ^ EDD Clin [14] ^ EDD Clin prov [15] ^ EDD Clin Date [16] ^EDD Clin Comment [17] ^ EDD unknown [18] ^EDD Unknown prov [19] ^EDD unknown date [20] ^ EDD unknown comment [21]
GET(RET,INP) ;EP
+1 NEW DFN,REC,HX,LMP,LMPDT,BEG,REPC,CONT,DELDT,METHOD,DAT,FNUM,EXP,CNT,REP,PREG,STR
+2 NEW X,Y,Z,G,M,F,P,E,L,T,S,GD,MD,FD,PD,ED,LD,TD,SD,REPDT,ARRAY
+3 SET RET=$$TMPGBL^BGOUTL
+4 SET FNUM=$$FNUM
+5 SET CNT=0
+6 SET DFN=+INP
+7 IF 'DFN
QUIT
+8 IF '$DATA(^AUPNREP(DFN))
QUIT
+9 SET DAT=$PIECE(INP,U,2)
+10 SET EXP=$PIECE(INP,U,3)
+11 SET REC=$GET(^AUPNREP(DFN,0))
+12 DO GETDATA
+13 SET CNT=CNT+1
+14 SET @RET@(CNT)="L"_U_LMP_U_LMPDT
+15 SET CNT=CNT+1
+16 IF EXP=1
Begin DoDot:1
+17 SET STR="Total # of pregnancies="_G_U_GD_U_"Multiple Births="_M_U_MD_U_"Full Term="_F_U_FD_U_"Premature="_P_U_PD_U
+18 SET STR=STR_"Ectopic Pregnancies="_E_U_ED_U_"Living Children="_L_U_LD_U_"Spontaneous Abortions (Miscarriages)="_S_U_SD_U_"Induced Abortions="_T_U_TD
+19 SET @RET@(CNT)="R"_U_STR
End DoDot:1
+20 IF '$TEST
SET @RET@(CNT)="R"_U_G_U_GD_U_M_U_MD_U_F_U_FD_U_P_U_PD_U_E_U_ED_U_L_U_LD_U_S_U_SD_U_T_U_TD
+21 ;Get lactation data
DO LAC^BGOREP1(.RET,.CNT,DFN)
+22 ;Get contraceptive data
DO CONT^BGOREP1(.RET,.CNT,DFN)
+23 ;Get menstrual data
DO MEN^BGOREP1(.RET,.CNT,DFN)
+24 ;Get EDD data
DO EDD^BGOREP1(.RET,.CNT,DFN)
+25 ;I DAT,$P(REC,U,3)'=DAT S HX=""
GETDATA ;Get the data needed for the repro history
+1 SET LMP=$PIECE(REC,U,4)
+2 IF DAT'=""
IF $PIECE(REC,U,5)'=DAT
SET LMP=""
+3 SET LMP=$$FMTDATE^BGOUTL(LMP)
+4 SET LMPDT=$PIECE(REC,U,5)
+5 SET LMPDT=$$FMTDATE^BGOUTL(LMPDT)
+6 SET REC=$GET(^AUPNREP(DFN,11))
+7 DO CHECK(REC)
+8 QUIT
+9 ; Add/edit reproductive factor
+10 ;INP=dfn of patient
+11 ;DATA is an array
+12 ;DATA(1)=L [1] ^ LMP [2] ^ DATE updated [3]
+13 ;DATA(2)=R [1] ^ Gravida [2]^ Date Updated [3] ^Multiple Births [4] ^ Date Updated [5] ^Full term [6] ^ Date Updated [7] ^Premature [8]
+14 ;^ Date Updated [9] ^Ectopics [10] ^ Date Updated [11] ^Living Children [12] ^ Date Updated [13] ^ Spontaneous abortions [14] ^ SA dt update[15]
+15 ;^ Induced abortions [16] ^ TA dt updated [17]
+16 ;DATA(3)=M [1] ^ Menarche age [2] ^Dte updated [3] ^coitarche age [4] ^date updated [5] ^menopause age [6] ^date updated [7] ^DES [8] ^Des updated [9]
+17 ;DATA(4)=E [1]^ PREGNANT [2]^ Dt updated [3] ^ Pregnant updated prov [4]
+18 ;^EDD LMP [5] ^ EDD LMP DT [6] ^ EDD LMP Prov [7] ^ EDD LMP COMMENT [8]
+19 ;^EDD ult [9] ^EDD ul dte [10] ^EDD ult prov [11] ^ EDD ult comment [12]
+20 ;^EDD Clin [13] ^ EDD Clin dte [14] ^ EDD Clin Prov [15] ^ EDD clin Comment [16
+21 ;^EDD unknown [17] ^EDD Unk dte [18] ^ EDD unk prv [19] ^ EDD unk comment [20]
+22 ;^EDD Def [21] ^ EDD Def Dte [22] ^EDD Def prov [23] ^ EDD Def Comment [24]
+23 ;DATA(5)="B [1] ^lac status [2] ^dt updated [3] ^prov update [4]
SET(RET,INP,DATA) ;EP
+1 NEW DFN,FNUM,REPHX,LMP,TXT,FP,ARRAY,FPDATE,IDX,PREG,DELIVDT,DELMETH,FDA,IENS,NEW,EDDTX
+2 NEW EDC,EDCBY,GRAV,GRAVDT,MB,MBDT,FT,FTDT,PRE,PREDT,EC,ECDT,LC,LCDT,SA,SADT,TA,TADT
+3 NEW DEDD,DEDDP,DEDDT,TODAY,TYPE,PRV
+4 SET PRV=$PIECE($GET(^VA(200,DUZ,0)),U,1)
+5 SET RET=""
SET FNUM=$$FNUM
+6 SET TODAY=$$DT^XLFDT
+7 SET DFN=+INP
+8 IF '$DATA(^DPT(DFN,0))
SET RET=$$ERR^BGOUTL(1001)
QUIT
+9 IF $PIECE(^DPT(DFN,0),U,2)'="F"
SET RET=$$ERR^BGOUTL(1052)
QUIT
+10 SET NEW='$DATA(^AUPNREP(DFN))
+11 SET IENS=$SELECT('NEW:DFN_",",1:"+1,")
+12 SET FDA=$NAME(FDA(FNUM,IENS))
+13 IF NEW
SET @FDA@(.01)="`"_DFN
+14 SET @FDA@(1.1)=TODAY
+15 SET (IDX,EDDTX)=""
+16 FOR
SET IDX=$ORDER(DATA(IDX))
IF 'IDX
QUIT
Begin DoDot:1
+17 SET TYPE=$PIECE(DATA(IDX),U,1)
+18 SET TXT=$GET(DATA(IDX))
+19 IF TYPE="B"
DO LAC(TXT)
+20 IF TYPE="L"
DO LMP(TXT)
+21 IF TYPE="R"
DO REP(TXT)
+22 IF TYPE="M"
DO MEN(TXT)
+23 IF TYPE="E"
DO EDD(TXT)
End DoDot:1
+24 IF NEW
Begin DoDot:1
+25 SET RET=$$UPDATE^BGOUTL(.FDA,"E")
End DoDot:1
+26 IF '$TEST
Begin DoDot:1
+27 NEW ERR
+28 DO FILE^DIE("E","FDA","ERR")
+29 IF $DATA(ERR("DIERR"))
SET RET=ERR("DIERR")
End DoDot:1
+30 IF 'RET
DO EVT(DFN,'NEW)
+31 ;I 'RET D STORE(EDDTX)
+32 KILL ERR
+33 DO STORE(EDDTX)
+34 IF 'RET
SET RET=DFN
+35 QUIT
LMP(TXT) ;Store LMP data
+1 NEW LMP,LMPUP
+2 SET LMP=$PIECE(TXT,U,2)
+3 SET LMPUP=$PIECE(TXT,U,3)
+4 IF LMPUP=""
SET LMPUP=$$EXTERNAL^DILFD(TODAY)
+5 IF LMP'=""
Begin DoDot:1
+6 SET @FDA@(2)=LMP
+7 SET @FDA@(2.1)=LMPUP
End DoDot:1
+8 QUIT
LAC(TXT) ;Store lactation data
+1 NEW LAC,LACUP,LACPR
+2 SET LAC=$$UP^XLFSTR($PIECE(TXT,U,2))
+3 SET LACUP=$PIECE(TXT,U,3)
+4 IF LACUP=""
SET LACUP=$$EXTERNAL^DILFD(TODAY)
+5 SET LACPR=$PIECE(TXT,U,4)
+6 IF LACPR=""
SET LACPR=PRV
+7 IF $LENGTH(LAC)
Begin DoDot:1
+8 SET @FDA@(2.01)=LAC
+9 IF $LENGTH(LACPR)
SET @FDA@(2.03)=LACPR
+10 IF $LENGTH(LACUP)
SET @FDA@(2.02)=LACUP
End DoDot:1
+11 QUIT
REP(INP) ;Store reproductive history data
+1 SET GRAV=$PIECE(INP,U,2)
SET GRAVDT=$PIECE(INP,U,3)
+2 IF GRAV'=""
Begin DoDot:1
+3 IF $LENGTH(GRAV)
SET @FDA@(1103)=GRAV
+4 IF $LENGTH(GRAVDT)
SET @FDA@(1104)=GRAVDT
+5 IF '$TEST
SET @FDA@(1104)=$$EXTERNAL^DILFD(TODAY)
End DoDot:1
+6 SET MB=$PIECE(INP,U,4)
SET MBDT=$PIECE(INP,U,5)
+7 IF MB'=""
Begin DoDot:1
+8 IF $LENGTH(MB)
SET @FDA@(1105)=MB
+9 IF $LENGTH(MBDT)
SET @FDA@(1106)=MBDT
+10 IF '$TEST
SET @FDA@(1106)=$$EXTERNAL^DILFD(TODAY)
End DoDot:1
+11 SET FT=$PIECE(INP,U,6)
SET FTDT=$PIECE(INP,U,7)
+12 IF FT'=""
Begin DoDot:1
+13 IF $LENGTH(FT)
SET @FDA@(1107)=FT
+14 IF $LENGTH(FTDT)
SET @FDA@(1108)=FTDT
+15 IF '$TEST
SET @FDA@(1108)=$$EXTERNAL^DILFD(TODAY)
End DoDot:1
+16 SET PRE=$PIECE(INP,U,8)
SET PREDT=$PIECE(INP,U,9)
+17 IF PRE'=""
Begin DoDot:1
+18 IF $LENGTH(PRE)
SET @FDA@(1109)=PRE
+19 IF $LENGTH(PREDT)
SET @FDA@(1110)=PREDT
+20 IF '$TEST
SET @FDA@(1110)=$$EXTERNAL^DILFD(TODAY)
End DoDot:1
+21 SET EC=$PIECE(INP,U,10)
SET ECDT=$PIECE(INP,U,11)
+22 IF EC'=""
Begin DoDot:1
+23 IF $LENGTH(EC)
SET @FDA@(1111)=EC
+24 IF $LENGTH(ECDT)
SET @FDA@(1112)=ECDT
+25 IF '$TEST
SET @FDA@(1112)=$$EXTERNAL^DILFD(TODAY)
End DoDot:1
+26 SET LC=$PIECE(INP,U,12)
SET LCDT=$PIECE(INP,U,13)
+27 IF LC'=""
Begin DoDot:1
+28 IF $LENGTH(LC)
SET @FDA@(1113)=LC
+29 IF $LENGTH(LCDT)
SET @FDA@(1114)=LCDT
+30 IF '$TEST
SET @FDA@(1114)=$$EXTERNAL^DILFD(TODAY)
End DoDot:1
+31 SET SA=$PIECE(INP,U,14)
SET SADT=$PIECE(INP,U,15)
+32 IF SA'=""
Begin DoDot:1
+33 IF $LENGTH(SA)
SET @FDA@(1133)=SA
+34 IF $LENGTH(SADT)
SET @FDA@(1134)=SADT
+35 IF '$TEST
SET @FDA@(1134)=$$EXTERNAL^DILFD(TODAY)
End DoDot:1
+36 SET TA=$PIECE(INP,U,16)
SET TADT=$PIECE(INP,U,17)
+37 IF TA'=""
Begin DoDot:1
+38 IF $LENGTH(TA)
SET @FDA@(1131)=TA
+39 IF $LENGTH(TADT)
SET @FDA@(1132)=TADT
+40 IF '$TEST
SET @FDA@(1132)=$$EXTERNAL^DILFD(TODAY)
End DoDot:1
+41 QUIT
MEN(TXT) ;Store menstrual history data
+1 NEW MAGE,CAGE,MENO,DES,MDT,CDT,MENODT,DESDT
+2 SET MAGE=$PIECE(TXT,U,2)
SET MDT=$PIECE(TXT,U,3)
+3 IF MAGE=""
SET MAGE="@"
+4 IF $LENGTH(MAGE)
SET @FDA@(1117)=MAGE
+5 IF $LENGTH(MDT)
SET @FDA@(1118)=MDT
+6 IF '$TEST
SET @FDA@(1118)=$$EXTERNAL^DILFD(TODAY)
+7 SET CAGE=$PIECE(TXT,U,4)
SET CDT=$PIECE(TXT,U,5)
+8 IF CAGE=""
SET CAGE="@"
+9 IF $LENGTH(CAGE)
SET @FDA@(1119)=CAGE
+10 IF $LENGTH(CDT)
SET @FDA@(1120)=CDT
+11 IF '$TEST
SET @FDA@(1120)=$$EXTERNAL^DILFD(TODAY)
+12 SET MENO=$PIECE(TXT,U,6)
SET MENODT=$PIECE(TXT,U,7)
+13 IF MENO=""
SET MENO="@"
+14 IF $LENGTH(MENO)
SET @FDA@(1121)=MENO
+15 IF $LENGTH(MENODT)
SET @FDA@(1122)=MENODT
+16 IF '$TEST
SET @FDA@(1122)=$$EXTERNAL^DILFD(TODAY)
+17 SET DES=$PIECE(TXT,U,8)
SET DESDT=$PIECE(TXT,U,9)
+18 IF DES'=""
Begin DoDot:1
+19 IF $LENGTH(DES)
SET @FDA@(1127)=DES
+20 IF $LENGTH(DESDT)
SET @FDA@(1128)=DESDT
+21 IF '$TEST
SET @FDA@(1128)=$$EXTERNAL^DILFD(TODAY)
End DoDot:1
+22 QUIT
EDD(TXT) ;Get EDD data string and save
+1 SET EDDTX=TXT
+2 QUIT
STORE(TXT) ;Store EDD data string
+1 NEW EDD,EDDP,EDDT,PREG,PREGPR,PREGDT,FDA,IENS,FNUM,EDDCO
+2 KILL FDA
+3 IF TXT=""
QUIT
+4 SET FNUM=$$FNUM
+5 SET IENS=DFN_","
+6 SET FDA=$NAME(FDA(FNUM,IENS))
+7 ;Pregnancy data
SET PREG=$PIECE(TXT,U,2)
SET PREGPR=$PIECE(TXT,U,3)
SET PREGDT=$PIECE(TXT,U,4)
+8 SET PREG=$$UPPER(PREG)
+9 IF PREGPR=""
SET PREGPR=PRV
+10 IF PREG'=""
Begin DoDot:1
+11 IF $LENGTH(PREG)
SET @FDA@(1101)=PREG
+12 IF $LENGTH(PREGPR)
SET @FDA@(1135)=PREGPR
+13 IF $LENGTH(PREGDT)
SET @FDA@(1102)=PREGDT
+14 IF '$TEST
SET @FDA@(1102)=$$EXTERNAL^DILFD(TODAY)
End DoDot:1
+15 ;EDD by LMP data
SET EDD=$PIECE(TXT,U,5)
SET EDDP=$PIECE(TXT,U,7)
SET EDDT=$PIECE(TXT,U,6)
SET EDDCO=$PIECE(TXT,U,8)
+16 IF EDDP=""
SET EDDP=PRV
+17 IF PREG="NO"!(PREG="No")
SET (EDD,EDDP,EDDT,EDDCO)="@"
+18 IF EDD'=""
Begin DoDot:1
+19 IF $LENGTH(EDD)
SET @FDA@(1302)=EDD
+20 IF $LENGTH(EDDP)
SET @FDA@(1304)=EDDP
+21 IF $LENGTH(EDDT)
SET @FDA@(1303)=EDDT
+22 IF '$TEST
SET @FDA@(1303)=$$EXTERNAL^DILFD(TODAY)
+23 IF $LENGTH(EDDCO)
SET @FDA@(1401)=EDDCO
End DoDot:1
+24 DO FILE^DIE("E","FDA","ERR")
+25 IF $DATA(ERR("DIERR"))
SET RET=ERR("DIERR")
+26 KILL FDA,ERR
+27 SET FDA=$NAME(FDA(FNUM,IENS))
+28 ;EDD by ultrasound data
SET EDD=$PIECE(TXT,U,9)
SET EDDP=$PIECE(TXT,U,11)
SET EDDT=$PIECE(TXT,U,10)
SET EDDCO=$PIECE(TXT,U,12)
+29 IF PREG="NO"!(PREG="No")
SET (EDD,EDDP,EDDT,EDDCO)="@"
+30 IF EDDP=""
SET EDDP=PRV
+31 IF EDD'=""
Begin DoDot:1
+32 IF $LENGTH(EDD)
SET @FDA@(1305)=EDD
+33 IF $LENGTH(EDD)
SET @FDA@(1307)=EDDP
+34 IF $LENGTH(EDDT)
SET @FDA@(1306)=EDDT
+35 IF '$TEST
SET @FDA@(1306)=$$EXTERNAL^DILFD(TODAY)
+36 IF $LENGTH(EDDCO)
SET @FDA@(1402)=EDDCO
+37 DO FILE^DIE("E","FDA","ERR")
End DoDot:1
+38 IF $DATA(ERR("DIERR"))
SET RET=ERR("DIERR")
+39 KILL FDA,ERR
+40 SET FDA=$NAME(FDA(FNUM,IENS))
+41 ;EDD by clinical parameters data
SET EDD=$PIECE(TXT,U,13)
SET EDDP=$PIECE(TXT,U,15)
SET EDDT=$PIECE(TXT,U,14)
SET EDDCO=$PIECE(TXT,U,16)
+42 IF PREG="NO"!(PREG="No")
SET (EDD,EDDP,EDDT,EDDCO)="@"
+43 IF EDDP=""
SET EDDP=PRV
+44 IF EDD'=""
Begin DoDot:1
+45 IF $LENGTH(EDD)
SET @FDA@(1308)=EDD
+46 IF $LENGTH(EDD)
SET @FDA@(1310)=EDDP
+47 IF $LENGTH(EDDT)
SET @FDA@(1309)=EDDT
+48 IF '$TEST
SET @FDA@(1309)=$$EXTERNAL^DILFD(TODAY)
+49 IF $LENGTH(EDDCO)
SET @FDA@(1501)=EDDCO
+50 DO FILE^DIE("E","FDA","ERR")
End DoDot:1
+51 IF $DATA(ERR("DIERR"))
SET RET=ERR("DIERR")
+52 KILL FDA,ERR
+53 SET FDA=$NAME(FDA(FNUM,IENS))
+54 ;EDD by known method data
SET EDD=$PIECE(TXT,U,17)
SET EDDP=$PIECE(TXT,U,19)
SET EDDT=$PIECE(TXT,U,18)
SET EDDCO=$PIECE(TXT,U,20)
+55 IF PREG="NO"!(PREG="No")
SET (EDD,EDDP,EDDT,EDDCO)="@"
+56 IF EDDP=""
SET EDDP=PRV
+57 IF EDD'=""
Begin DoDot:1
+58 IF $LENGTH(EDD)
SET @FDA@(1314)=EDD
+59 IF $LENGTH(EDD)
SET @FDA@(1316)=EDDP
+60 IF $LENGTH(EDDT)
SET @FDA@(1315)=EDDT
+61 IF '$TEST
SET @FDA@(1315)=$$EXTERNAL^DILFD(TODAY)
+62 IF $LENGTH(EDDCO)
SET @FDA@(1601)=EDDCO
+63 DO FILE^DIE("E","FDA","ERR")
End DoDot:1
+64 IF $DATA(ERR("DIERR"))
SET RET=ERR("DIERR")
+65 SET DEDD=$PIECE(TXT,U,21)
SET DEDDP=$PIECE(TXT,U,23)
SET DEDDT=$PIECE(TXT,U,22)
SET EDDCO=$PIECE(TXT,U,24)
+66 KILL FDA,ERR
+67 SET FDA=$NAME(FDA(FNUM,IENS))
+68 IF PREG="NO"!(PREG="No")
SET (DEDD,DEDDP,DEDDT,EDDCO)="@"
+69 IF DEDDP=""
SET DEDDP=PRV
+70 IF DEDD'=""
Begin DoDot:1
+71 IF $LENGTH(DEDD)
SET @FDA@(1311)=DEDD
+72 IF $LENGTH(DEDD)
SET @FDA@(1313)=DEDDP
+73 IF $LENGTH(DEDDT)
SET @FDA@(1312)=DEDDT
+74 IF '$TEST
SET @FDA@(1312)=$$EXTERNAL^DILFD(TODAY)
+75 IF $LENGTH(EDDCO)
SET @FDA@(1502)=EDDCO
+76 DO FILE^DIE("E","FDA","ERR")
End DoDot:1
+77 IF $DATA(ERR("DIERR"))
SET RET=ERR("DIERR")
+78 QUIT
+79 ; Delete reproductive history
+80 ; DFN = Patient IEN
DEL(RET,DFN) ;EP
+1 SET RET=$$DELETE^BGOUTL("^AUPNREP(",DFN)
+2 IF 'RET
DO EVT(DFN,2)
+3 QUIT
+4 ; Fire file update events
+5 ; IEN = File IEN ( = patient IEN)
+6 ; OPR = Operation (0 = add, 1 = edit, 2 = delete)
EVT(IEN,OPR) ;EP
+1 NEW DATA
+2 SET DATA=IEN_U_$GET(CIA("UID"))_U_OPR_U_IEN
+3 DO BRDCAST^CIANBEVT("PCC."_IEN_".REP",DATA)
+4 QUIT
+5 ; Expand reproductive history
EXPHX(DFN) ;
+1 NEW REC,HX,LMP,BEG,REPC,CONT,DELDT,METHOD,FNUM,EXP,CNT,REP,PREG,STR
+2 NEW X,Y,Z,G,M,F,P,E,L,T,S,GD,MD,FD,PD,ED,LD,TD,SD,REPDT,X2,TRGSTR
+3 SET TRGSTR=""
+4 IF 'DFN
QUIT
+5 IF '$DATA(^AUPNREP(DFN))
QUIT
+6 SET FNUM=$$FNUM
+7 SET REC=$GET(^AUPNREP(DFN,0))
+8 DO GETDATA
+9 SET STR="Total Preg="_G_";Multiple Births="_M_";Full Term="_F_";Premature="_P
+10 SET STR=STR_";Ectopics="_E_";Living="_L_";SponAb="_S_";TxAb="_T
+11 SET TRGSTR=STR
+12 QUIT TRGSTR
CHECK(REP) ;Get the different reproductive elements
+1 SET REPDT=$PIECE(REP,U,30)
+2 SET REPDT=$$FMTDATE^BGOUTL(REPDT)
+3 SET G=$PIECE(REP,U,3)
SET GD=$$FMTDATE^BGOUTL($PIECE(REP,U,4))
+4 IF G=""
SET G=0
+5 SET M=$PIECE(REP,U,5)
SET MD=$$FMTDATE^BGOUTL($PIECE(REP,U,6))
+6 SET F=$PIECE(REP,U,7)
SET FD=$$FMTDATE^BGOUTL($PIECE(REP,U,8))
+7 SET P=$PIECE(REP,U,9)
SET PD=$$FMTDATE^BGOUTL($PIECE(REP,U,10))
+8 SET E=$PIECE(REP,U,11)
SET ED=$$FMTDATE^BGOUTL($PIECE(REP,U,12))
+9 SET L=$PIECE(REP,U,13)
SET LD=$$FMTDATE^BGOUTL($PIECE(REP,U,14))
+10 SET T=$PIECE(REP,U,31)
SET TD=$$FMTDATE^BGOUTL($PIECE(REP,U,32))
+11 SET S=$PIECE(REP,U,33)
SET SD=$$FMTDATE^BGOUTL($PIECE(REP,U,34))
+12 QUIT
UPPER(X) ;Turn value to upper case
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ; Return file number
FNUM() QUIT 9000017
