BGOREP1 ; IHS/BAO/TMD - Manage REPRODUCTIVE FACTORS ;08-May-2014 14:11;du
;;1.1;BGO COMPONENTS;**10,11,14**;Mar 20, 2007;Build 2
; 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
LAC(RET,CNT,DFN) ;EP get lactation data
N REP,LAC,LACDT,LACPR
S REP=$G(^AUPNREP(DFN,2))
S LAC=$$EXTERNAL^DILFD(FNUM,2.01,,$P(REP,U,1))
S LACDT=$P(REP,U,2)
S LACDT=$$FMTDATE^BGOUTL(LACDT)
S LACPR=$$EXTERNAL^DILFD(FNUM,2.03,,$P(REP,U,3))
S CNT=CNT+1
S @RET@(CNT)="B"_U_LAC_U_LACPR_U_LACDT
Q
MEN(RET,CNT,DFN) ;get menstrual data
N REP,MA,CA,MENO,DES,DESDT,MAD,CAD,MENOD
S REP=$G(^AUPNREP(DFN,11))
S MA=$$EXTERNAL^DILFD(FNUM,1117,,$P(REP,U,17))
S MAD=$P(REP,U,18)
S MAD=$$FMTDATE^BGOUTL(MAD)
S CA=$$EXTERNAL^DILFD(FNUM,1119,,$P(REP,U,19))
S CAD=$P(REP,U,20)
S CAD=$$FMTDATE^BGOUTL(CAD)
S MENO=$$EXTERNAL^DILFD(FNUM,1121,,$P(REP,U,21))
S MENOD=$P(REP,U,22)
S MENOD=$$FMTDATE^BGOUTL(MENOD)
S CNT=CNT+1
S @RET@(CNT)="M"_U_MA_U_MAD_U_CA_U_CAD_U_MENO_U_MENOD
S DES=$$EXTERNAL^DILFD(FNUM,1127,,$P(REP,U,27))
S DESDT=$P($G(^AUPNREP(DFN,11)),U,28)
S DESDT=$$FMTDATE^BGOUTL(DESDT)
S CNT=CNT+1
S @RET@(CNT)="D"_U_DES_U_DESDT
Q
EDD(RET,CNT,DFN) ;Get pregnancy data
N REP,LMP,LMPPR,LMPDT,ULTRA,ULTPR,ULTDT,CLIN,CLINPR,CLINDT,UN,UNPR,UNDT,EDD,EDDPR,EDDDT
N PREG,PREGDT,PREGPR,LMPCO,ULTCO,DEFCO,UNCO,CLINCO,EDDCO
S REP=$G(^AUPNREP(DFN,13))
S PREG=$P($G(^AUPNREP(DFN,11)),U,1)
S PREG=$$EXTERNAL^DILFD(FNUM,1101,,PREG)
S PREGDT=$P($G(^AUPNREP(DFN,11)),U,2)
S PREGDT=$$FMTDATE^BGOUTL(PREGDT)
S PREGPR=$P($G(^AUPNREP(DFN,11)),U,35)
S PREGPR=$$EXTERNAL^DILFD(FNUM,1304,,PREGPR)
;EDD by LMP
S LMP=$P(REP,U,2)
S LMP=$$FMTDATE^BGOUTL(LMP)
S LMPDT=$P(REP,U,3)
S LMPDT=$$FMTDATE^BGOUTL(LMPDT)
S LMPPR=$$EXTERNAL^DILFD(FNUM,1304,,$P(REP,U,4))
S LMPCO=$P($G(^AUPNREP(DFN,14)),U,1)
;EDD by ultrasound
S ULTRA=$P(REP,U,5)
S ULTRA=$$FMTDATE^BGOUTL(ULTRA)
S ULTDT=$P(REP,U,6)
S ULTDT=$$FMTDATE^BGOUTL(ULTDT)
S ULTPR=$$EXTERNAL^DILFD(FNUM,1307,,$P(REP,U,7))
S ULTCO=$P($G(^AUPNREP(DFN,14)),U,2)
;EDD by clinical parameters
S CLIN=$P(REP,U,8)
S CLIN=$$FMTDATE^BGOUTL(CLIN)
S CLINDT=$P(REP,U,9)
S CLINDT=$$FMTDATE^BGOUTL(CLINDT)
S CLINPR=$$EXTERNAL^DILFD(FNUM,1310,,$P(REP,U,10))
S CLINCO=$P($G(^AUPNREP(DFN,15)),U,1)
S EDD=$P(REP,U,11)
S EDD=$$FMTDATE^BGOUTL(EDD)
;S EDD=$$EXTERNAL^DILFD(FNUM,1311,,$P(REP,U,11))
S EDDDT=$P(REP,U,12)
S EDDDT=$$FMTDATE^BGOUTL(EDDDT)
S EDDPR=$$EXTERNAL^DILFD(FNUM,1313,,$P(REP,U,13))
S EDDCO=$P($G(^AUPNREP(DFN,15)),U,2)
;EDD by unknown methods
S UN=$P(REP,U,14)
S UN=$$FMTDATE^BGOUTL(UN)
S UNDT=$P(REP,U,15)
S UNDT=$$FMTDATE^BGOUTL(UNDT)
S UNPR=$$EXTERNAL^DILFD(FNUM,1316,,$P(REP,U,16))
S UNCO=$P($G(^AUPNREP(DFN,16)),U,1)
S CNT=CNT+1
S @RET@(CNT)="P"_U_PREG_U_PREGPR_U_PREGDT
S CNT=CNT+1
S @RET@(CNT)="E"_U_EDD_U_EDDPR_U_EDDDT_U_EDDCO_U_LMP_U_LMPPR_U_LMPDT_U_LMPCO_U_ULTRA_U_ULTPR_U_ULTDT_U_ULTCO_U_CLIN_U_CLINPR_U_CLINDT_U_CLINCO_U_UN_U_UNPR_U_UNDT_U_UNCO
Q
CONT(RET,CNT,DFN) ; Get contraceptive data
N I,NODE,NAME,CNAME,CHK,CBEGUN,STRING,REC,FNUM
S STRING="",CHK=0
S I=0 F S I=$O(^AUPNREP(DFN,2101,I)) Q:I=""!('+I) D
.S NODE=$G(^AUPNREP(DFN,2101,I,0))
.Q:$D(^AUPNREP(DFN,2101,I,1))>0
.S CHK=CHK+1
.I $P(NODE,U,3)="" D
..S NAME=$P(NODE,U,1),CBEGUN=$P(NODE,U,2)
..S CBEGUN=$$FMTDATE^BGOUTL(CBEGUN)
..S CNAME=$P($G(^AUTTCM(NAME,0)),U,1)
..I CNAME="OTHER" S CNAME=CNAME_"-"_$P(NODE,U,6)
..I STRING="" S STRING=CNAME_";"_CBEGUN
..E S STRING=STRING_"^"_CNAME_";"_CBEGUN
I CHK=0 D
.;S FNUM=$$FNUM^BGOREP
.;S REC=$G(^AUPNREP(DFN,0))
.;S CNAME=$$EXTERNAL^DILFD(FNUM,3,,$P(REC,U,6))
.;S CBEGUN=$P(REC,U,7)
.;S CBEGUN=$$FMTDATE^BGOUTL(CBEGUN)
.;I CNAME'="" S STRING=CNAME_";"_CBEGUN
S CNT=CNT+1
S @RET@(CNT)="C"_U_STRING
Q
CONTALL(RET,DFN) ;EP for RPC call to get all contrceptive data
; Input DFN of patient
;Output string:
;IEN of subfile [1] ^ method [2] ^ date started [3] ^ date ended [4] ^ reason DC [5] ^ comment [6]
N CNT,NODE,I,J,NAME,CNAME,BEGUN,CDATE,STRING,ARRAY,CEND,COMM,CREA
K ARRAY
S RET=$$TMPGBL^BGOUTL
S STRING="",CNT=0
S I=0 F S I=$O(^AUPNREP(DFN,2101,I)) Q:I=""!('+I) D
.Q:$D(^AUPNREP(DFN,2101,I,1))>0
.S NODE=$G(^AUPNREP(DFN,2101,I,0))
.I NODE'="" D
..S NAME=$P(NODE,U,1)
..S CDATE=$P(NODE,U,2)
..S CBEGUN=$$FMTDATE^BGOUTL(CDATE)
..S CNAME=$P($G(^AUTTCM(NAME,0)),U,1)
..S CEND=$P(NODE,U,3)
..S CEND=$$FMTDATE^BGOUTL(CEND)
..S CREA=$P(NODE,U,5)
..S COMM=$P(NODE,U,6)
..S ARRAY(9999999-CDATE,I)=I_U_CNAME_U_CBEGUN_U_CEND_U_CREA_U_COMM
I '$D(ARRAY) S @RET@(1)="" Q
I $D(ARRAY)>0 D
.S I=0 F S I=$O(ARRAY(I)) Q:I="" D
..S J=0 F S J=$O(ARRAY(I,J)) Q:J="" D
...S CNT=CNT+1
...S @RET@(CNT)=$G(ARRAY(I,J))
Q
;Set items into the contracepton multiple
;Input= DFN - patient
;DATA= array of items to be edited/stored in this format
; (n)= IEN of subfile (if edit) [1] ^ Type of contraception [2] ^ date start [3] ^ date end [4] ^ reason DC [5] ^ comment [6]
SETCONT(RET,DFN,DATA) ;EP
N I,FNUM,NEW,AIEN,IENS,NODE,CON,CONB,CIEN,CONE,CONDC,COM,TODAY,FDA,IEN,ERR
S RET="",FNUM=$$FNUM^BGOREP
S TODAY=$$DT^XLFDT
S DFN=+DFN
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))
I NEW D
.S IENS="+1,"
.S FDA(9000017,"+1,",.01)=DFN
.S IEN(1)=DFN
.S FDA(9000017,"+1,",1.1)=TODAY
.D UPDATE^DIE("","FDA","IEN","ERR")
.I $D(IEN(1)) S RET=""
.I $D(ERR) S RET="Unable to store patient"
S I="" F S I=$O(DATA(I)) Q:I=""!(RET'="") D
.K FDA
.S NODE=$G(DATA(I))
.S FNUM=9000017.02101
.Q:$P(NODE,U,2)=""
.I $P(NODE,U,1)="" D NEW Q
.E S AIEN=$P(NODE,U,1)_","_DFN_","
.S FDA=$NA(FDA(FNUM,AIEN))
.S CON=$P(NODE,U,2)
.S:$L(CON) @FDA@(.01)=CON
.S CONB=$$SDATE($P(NODE,U,3))
.S:$L(CONB) @FDA@(.02)=CONB
.S CONE=$$SDATE($P(NODE,U,4))
.I CONE="" S CONE="@"
.S @FDA@(.03)=CONE
.S @FDA@(.04)=$$FMTE^XLFDT(DT)
.S CONDC=$P(NODE,U,5)
.S:$L(CONDC) @FDA@(.05)=CONDC
.S COM=$P(NODE,U,6)
.S:$L(COM) @FDA@(.06)=COM
.S RET=$$UPDATE^BGOUTL(.FDA,"E@")
.D:'$D(ERR) EVT^BGOREP(DFN,1)
S:'$D(ERR) RET=DFN
Q
SDATE(IDATE) ;Format date
N DATA,MO,DAY
S DAY=$E(IDATE,4,5)
S MO=$E(IDATE,1,2)
I DAY="00"&(MO="00") S DATA=$E(IDATE,7,10) Q DATA
I DAY="00" S DATA=MO_"/"_$E(IDATE,7,10) Q DATA
E S DATA=IDATE
Q DATA
NEW ;Add new one
N APCDCMI,APCDREPI,DA,DIC,DIE,X,CON,CONB,CONE,COM,CONDC
S APCDREPI=DFN
S CON=$P(NODE,U,2)
S CON=$O(^AUTTCM("B",CON,""))
Q:CON=""
S DIC(0)="AEMQ"
S DIC="^AUPNREP("_APCDREPI_",2101,"
S DA(1)=APCDREPI
S DIC("P")=$P(^DD(9000017,2101,0),U,2)
S X=CON
S DIE("NO^")=1
S DIC("DR")=""
K DD,D0,DO
D FILE^DICN
S CONB=$P(NODE,U,3)
S CONE=$P(NODE,U,4)
I CONE="" S CONE="@"
S CONDC=$P(NODE,U,5)
S COM=$P(NODE,U,6)
S DIE("NO^")=1
S (APCDY,DA)=+Y,DA(1)=APCDREPI,DR=".02///"_CONB_";.03///"_CONE_";.04///^S X=$$FMTE^XLFDT(DT)"_";.05///"_CONDC_";.06///"_COM
S DIE="^AUPNREP("_APCDREPI_",2101,",DIE("NO^")=1
D ^DIE
K DIE,DR,DA
D EVT^BGOREP(DFN,1)
Q
DELCONT(RET,DFN,INP) ;EP-
N RET,SIEN,DIE,DA,IEN,APCDY,APCDCM,IENS,FDA,REA,COMM
S RET=""
Q:'DFN
Q:$P(INP,U,1)=""
;K DIC,DA,DR
S APCDY=$P(INP,U,1)
S REA=$P(INP,U,7)
S COMM=$P(INP,U,8)
I REA="" S REA="ENTERED IN ERROR"
;S DA=APCDY,DA(1)=DFN,DR=".01///@"
;S DIE="^AUPNREP("_DFN_",2101,"
;D ^DIE
S SIEN=APCDY_","_DFN_","
S FDA(9000017.02101,SIEN,1.01)=DUZ
S FDA(9000017.02101,SIEN,1.02)=$$NOW^XLFDT
S FDA(9000017.02101,SIEN,1.03)=REA
S FDA(9000017.02101,SIEN,1.04)=COMM
D FILE^DIE("","FDA","ERR")
S DA=APCDY,DA(1)=DFN D MULTOSET^APCDRF
K DA
D EVT^BGOREP(DFN,2)
Q
BGOREP1 ; IHS/BAO/TMD - Manage REPRODUCTIVE FACTORS ;08-May-2014 14:11;du
+1 ;;1.1;BGO COMPONENTS;**10,11,14**;Mar 20, 2007;Build 2
+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
LAC(RET,CNT,DFN) ;EP get lactation data
+1 NEW REP,LAC,LACDT,LACPR
+2 SET REP=$GET(^AUPNREP(DFN,2))
+3 SET LAC=$$EXTERNAL^DILFD(FNUM,2.01,,$PIECE(REP,U,1))
+4 SET LACDT=$PIECE(REP,U,2)
+5 SET LACDT=$$FMTDATE^BGOUTL(LACDT)
+6 SET LACPR=$$EXTERNAL^DILFD(FNUM,2.03,,$PIECE(REP,U,3))
+7 SET CNT=CNT+1
+8 SET @RET@(CNT)="B"_U_LAC_U_LACPR_U_LACDT
+9 QUIT
MEN(RET,CNT,DFN) ;get menstrual data
+1 NEW REP,MA,CA,MENO,DES,DESDT,MAD,CAD,MENOD
+2 SET REP=$GET(^AUPNREP(DFN,11))
+3 SET MA=$$EXTERNAL^DILFD(FNUM,1117,,$PIECE(REP,U,17))
+4 SET MAD=$PIECE(REP,U,18)
+5 SET MAD=$$FMTDATE^BGOUTL(MAD)
+6 SET CA=$$EXTERNAL^DILFD(FNUM,1119,,$PIECE(REP,U,19))
+7 SET CAD=$PIECE(REP,U,20)
+8 SET CAD=$$FMTDATE^BGOUTL(CAD)
+9 SET MENO=$$EXTERNAL^DILFD(FNUM,1121,,$PIECE(REP,U,21))
+10 SET MENOD=$PIECE(REP,U,22)
+11 SET MENOD=$$FMTDATE^BGOUTL(MENOD)
+12 SET CNT=CNT+1
+13 SET @RET@(CNT)="M"_U_MA_U_MAD_U_CA_U_CAD_U_MENO_U_MENOD
+14 SET DES=$$EXTERNAL^DILFD(FNUM,1127,,$PIECE(REP,U,27))
+15 SET DESDT=$PIECE($GET(^AUPNREP(DFN,11)),U,28)
+16 SET DESDT=$$FMTDATE^BGOUTL(DESDT)
+17 SET CNT=CNT+1
+18 SET @RET@(CNT)="D"_U_DES_U_DESDT
+19 QUIT
EDD(RET,CNT,DFN) ;Get pregnancy data
+1 NEW REP,LMP,LMPPR,LMPDT,ULTRA,ULTPR,ULTDT,CLIN,CLINPR,CLINDT,UN,UNPR,UNDT,EDD,EDDPR,EDDDT
+2 NEW PREG,PREGDT,PREGPR,LMPCO,ULTCO,DEFCO,UNCO,CLINCO,EDDCO
+3 SET REP=$GET(^AUPNREP(DFN,13))
+4 SET PREG=$PIECE($GET(^AUPNREP(DFN,11)),U,1)
+5 SET PREG=$$EXTERNAL^DILFD(FNUM,1101,,PREG)
+6 SET PREGDT=$PIECE($GET(^AUPNREP(DFN,11)),U,2)
+7 SET PREGDT=$$FMTDATE^BGOUTL(PREGDT)
+8 SET PREGPR=$PIECE($GET(^AUPNREP(DFN,11)),U,35)
+9 SET PREGPR=$$EXTERNAL^DILFD(FNUM,1304,,PREGPR)
+10 ;EDD by LMP
+11 SET LMP=$PIECE(REP,U,2)
+12 SET LMP=$$FMTDATE^BGOUTL(LMP)
+13 SET LMPDT=$PIECE(REP,U,3)
+14 SET LMPDT=$$FMTDATE^BGOUTL(LMPDT)
+15 SET LMPPR=$$EXTERNAL^DILFD(FNUM,1304,,$PIECE(REP,U,4))
+16 SET LMPCO=$PIECE($GET(^AUPNREP(DFN,14)),U,1)
+17 ;EDD by ultrasound
+18 SET ULTRA=$PIECE(REP,U,5)
+19 SET ULTRA=$$FMTDATE^BGOUTL(ULTRA)
+20 SET ULTDT=$PIECE(REP,U,6)
+21 SET ULTDT=$$FMTDATE^BGOUTL(ULTDT)
+22 SET ULTPR=$$EXTERNAL^DILFD(FNUM,1307,,$PIECE(REP,U,7))
+23 SET ULTCO=$PIECE($GET(^AUPNREP(DFN,14)),U,2)
+24 ;EDD by clinical parameters
+25 SET CLIN=$PIECE(REP,U,8)
+26 SET CLIN=$$FMTDATE^BGOUTL(CLIN)
+27 SET CLINDT=$PIECE(REP,U,9)
+28 SET CLINDT=$$FMTDATE^BGOUTL(CLINDT)
+29 SET CLINPR=$$EXTERNAL^DILFD(FNUM,1310,,$PIECE(REP,U,10))
+30 SET CLINCO=$PIECE($GET(^AUPNREP(DFN,15)),U,1)
+31 SET EDD=$PIECE(REP,U,11)
+32 SET EDD=$$FMTDATE^BGOUTL(EDD)
+33 ;S EDD=$$EXTERNAL^DILFD(FNUM,1311,,$P(REP,U,11))
+34 SET EDDDT=$PIECE(REP,U,12)
+35 SET EDDDT=$$FMTDATE^BGOUTL(EDDDT)
+36 SET EDDPR=$$EXTERNAL^DILFD(FNUM,1313,,$PIECE(REP,U,13))
+37 SET EDDCO=$PIECE($GET(^AUPNREP(DFN,15)),U,2)
+38 ;EDD by unknown methods
+39 SET UN=$PIECE(REP,U,14)
+40 SET UN=$$FMTDATE^BGOUTL(UN)
+41 SET UNDT=$PIECE(REP,U,15)
+42 SET UNDT=$$FMTDATE^BGOUTL(UNDT)
+43 SET UNPR=$$EXTERNAL^DILFD(FNUM,1316,,$PIECE(REP,U,16))
+44 SET UNCO=$PIECE($GET(^AUPNREP(DFN,16)),U,1)
+45 SET CNT=CNT+1
+46 SET @RET@(CNT)="P"_U_PREG_U_PREGPR_U_PREGDT
+47 SET CNT=CNT+1
+48 SET @RET@(CNT)="E"_U_EDD_U_EDDPR_U_EDDDT_U_EDDCO_U_LMP_U_LMPPR_U_LMPDT_U_LMPCO_U_ULTRA_U_ULTPR_U_ULTDT_U_ULTCO_U_CLIN_U_CLINPR_U_CLINDT_U_CLINCO_U_UN_U_UNPR_U_UNDT_U_UNCO
+49 QUIT
CONT(RET,CNT,DFN) ; Get contraceptive data
+1 NEW I,NODE,NAME,CNAME,CHK,CBEGUN,STRING,REC,FNUM
+2 SET STRING=""
SET CHK=0
+3 SET I=0
FOR
SET I=$ORDER(^AUPNREP(DFN,2101,I))
IF I=""!('+I)
QUIT
Begin DoDot:1
+4 SET NODE=$GET(^AUPNREP(DFN,2101,I,0))
+5 IF $DATA(^AUPNREP(DFN,2101,I,1))>0
QUIT
+6 SET CHK=CHK+1
+7 IF $PIECE(NODE,U,3)=""
Begin DoDot:2
+8 SET NAME=$PIECE(NODE,U,1)
SET CBEGUN=$PIECE(NODE,U,2)
+9 SET CBEGUN=$$FMTDATE^BGOUTL(CBEGUN)
+10 SET CNAME=$PIECE($GET(^AUTTCM(NAME,0)),U,1)
+11 IF CNAME="OTHER"
SET CNAME=CNAME_"-"_$PIECE(NODE,U,6)
+12 IF STRING=""
SET STRING=CNAME_";"_CBEGUN
+13 IF '$TEST
SET STRING=STRING_"^"_CNAME_";"_CBEGUN
End DoDot:2
End DoDot:1
+14 IF CHK=0
Begin DoDot:1
+15 ;S FNUM=$$FNUM^BGOREP
+16 ;S REC=$G(^AUPNREP(DFN,0))
+17 ;S CNAME=$$EXTERNAL^DILFD(FNUM,3,,$P(REC,U,6))
+18 ;S CBEGUN=$P(REC,U,7)
+19 ;S CBEGUN=$$FMTDATE^BGOUTL(CBEGUN)
+20 ;I CNAME'="" S STRING=CNAME_";"_CBEGUN
End DoDot:1
+21 SET CNT=CNT+1
+22 SET @RET@(CNT)="C"_U_STRING
+23 QUIT
CONTALL(RET,DFN) ;EP for RPC call to get all contrceptive data
+1 ; Input DFN of patient
+2 ;Output string:
+3 ;IEN of subfile [1] ^ method [2] ^ date started [3] ^ date ended [4] ^ reason DC [5] ^ comment [6]
+4 NEW CNT,NODE,I,J,NAME,CNAME,BEGUN,CDATE,STRING,ARRAY,CEND,COMM,CREA
+5 KILL ARRAY
+6 SET RET=$$TMPGBL^BGOUTL
+7 SET STRING=""
SET CNT=0
+8 SET I=0
FOR
SET I=$ORDER(^AUPNREP(DFN,2101,I))
IF I=""!('+I)
QUIT
Begin DoDot:1
+9 IF $DATA(^AUPNREP(DFN,2101,I,1))>0
QUIT
+10 SET NODE=$GET(^AUPNREP(DFN,2101,I,0))
+11 IF NODE'=""
Begin DoDot:2
+12 SET NAME=$PIECE(NODE,U,1)
+13 SET CDATE=$PIECE(NODE,U,2)
+14 SET CBEGUN=$$FMTDATE^BGOUTL(CDATE)
+15 SET CNAME=$PIECE($GET(^AUTTCM(NAME,0)),U,1)
+16 SET CEND=$PIECE(NODE,U,3)
+17 SET CEND=$$FMTDATE^BGOUTL(CEND)
+18 SET CREA=$PIECE(NODE,U,5)
+19 SET COMM=$PIECE(NODE,U,6)
+20 SET ARRAY(9999999-CDATE,I)=I_U_CNAME_U_CBEGUN_U_CEND_U_CREA_U_COMM
End DoDot:2
End DoDot:1
+21 IF '$DATA(ARRAY)
SET @RET@(1)=""
QUIT
+22 IF $DATA(ARRAY)>0
Begin DoDot:1
+23 SET I=0
FOR
SET I=$ORDER(ARRAY(I))
IF I=""
QUIT
Begin DoDot:2
+24 SET J=0
FOR
SET J=$ORDER(ARRAY(I,J))
IF J=""
QUIT
Begin DoDot:3
+25 SET CNT=CNT+1
+26 SET @RET@(CNT)=$GET(ARRAY(I,J))
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;Set items into the contracepton multiple
+29 ;Input= DFN - patient
+30 ;DATA= array of items to be edited/stored in this format
+31 ; (n)= IEN of subfile (if edit) [1] ^ Type of contraception [2] ^ date start [3] ^ date end [4] ^ reason DC [5] ^ comment [6]
SETCONT(RET,DFN,DATA) ;EP
+1 NEW I,FNUM,NEW,AIEN,IENS,NODE,CON,CONB,CIEN,CONE,CONDC,COM,TODAY,FDA,IEN,ERR
+2 SET RET=""
SET FNUM=$$FNUM^BGOREP
+3 SET TODAY=$$DT^XLFDT
+4 SET DFN=+DFN
+5 IF '$DATA(^DPT(DFN,0))
SET RET=$$ERR^BGOUTL(1001)
QUIT
+6 IF $PIECE(^DPT(DFN,0),U,2)'="F"
SET RET=$$ERR^BGOUTL(1052)
QUIT
+7 SET NEW='$DATA(^AUPNREP(DFN))
+8 IF NEW
Begin DoDot:1
+9 SET IENS="+1,"
+10 SET FDA(9000017,"+1,",.01)=DFN
+11 SET IEN(1)=DFN
+12 SET FDA(9000017,"+1,",1.1)=TODAY
+13 DO UPDATE^DIE("","FDA","IEN","ERR")
+14 IF $DATA(IEN(1))
SET RET=""
+15 IF $DATA(ERR)
SET RET="Unable to store patient"
End DoDot:1
+16 SET I=""
FOR
SET I=$ORDER(DATA(I))
IF I=""!(RET'="")
QUIT
Begin DoDot:1
+17 KILL FDA
+18 SET NODE=$GET(DATA(I))
+19 SET FNUM=9000017.02101
+20 IF $PIECE(NODE,U,2)=""
QUIT
+21 IF $PIECE(NODE,U,1)=""
DO NEW
QUIT
+22 IF '$TEST
SET AIEN=$PIECE(NODE,U,1)_","_DFN_","
+23 SET FDA=$NAME(FDA(FNUM,AIEN))
+24 SET CON=$PIECE(NODE,U,2)
+25 IF $LENGTH(CON)
SET @FDA@(.01)=CON
+26 SET CONB=$$SDATE($PIECE(NODE,U,3))
+27 IF $LENGTH(CONB)
SET @FDA@(.02)=CONB
+28 SET CONE=$$SDATE($PIECE(NODE,U,4))
+29 IF CONE=""
SET CONE="@"
+30 SET @FDA@(.03)=CONE
+31 SET @FDA@(.04)=$$FMTE^XLFDT(DT)
+32 SET CONDC=$PIECE(NODE,U,5)
+33 IF $LENGTH(CONDC)
SET @FDA@(.05)=CONDC
+34 SET COM=$PIECE(NODE,U,6)
+35 IF $LENGTH(COM)
SET @FDA@(.06)=COM
+36 SET RET=$$UPDATE^BGOUTL(.FDA,"E@")
+37 IF '$DATA(ERR)
DO EVT^BGOREP(DFN,1)
End DoDot:1
+38 IF '$DATA(ERR)
SET RET=DFN
+39 QUIT
SDATE(IDATE) ;Format date
+1 NEW DATA,MO,DAY
+2 SET DAY=$EXTRACT(IDATE,4,5)
+3 SET MO=$EXTRACT(IDATE,1,2)
+4 IF DAY="00"&(MO="00")
SET DATA=$EXTRACT(IDATE,7,10)
QUIT DATA
+5 IF DAY="00"
SET DATA=MO_"/"_$EXTRACT(IDATE,7,10)
QUIT DATA
+6 IF '$TEST
SET DATA=IDATE
+7 QUIT DATA
NEW ;Add new one
+1 NEW APCDCMI,APCDREPI,DA,DIC,DIE,X,CON,CONB,CONE,COM,CONDC
+2 SET APCDREPI=DFN
+3 SET CON=$PIECE(NODE,U,2)
+4 SET CON=$ORDER(^AUTTCM("B",CON,""))
+5 IF CON=""
QUIT
+6 SET DIC(0)="AEMQ"
+7 SET DIC="^AUPNREP("_APCDREPI_",2101,"
+8 SET DA(1)=APCDREPI
+9 SET DIC("P")=$PIECE(^DD(9000017,2101,0),U,2)
+10 SET X=CON
+11 SET DIE("NO^")=1
+12 SET DIC("DR")=""
+13 KILL DD,D0,DO
+14 DO FILE^DICN
+15 SET CONB=$PIECE(NODE,U,3)
+16 SET CONE=$PIECE(NODE,U,4)
+17 IF CONE=""
SET CONE="@"
+18 SET CONDC=$PIECE(NODE,U,5)
+19 SET COM=$PIECE(NODE,U,6)
+20 SET DIE("NO^")=1
+21 SET (APCDY,DA)=+Y
SET DA(1)=APCDREPI
SET DR=".02///"_CONB_";.03///"_CONE_";.04///^S X=$$FMTE^XLFDT(DT)"_";.05///"_CONDC_";.06///"_COM
+22 SET DIE="^AUPNREP("_APCDREPI_",2101,"
SET DIE("NO^")=1
+23 DO ^DIE
+24 KILL DIE,DR,DA
+25 DO EVT^BGOREP(DFN,1)
+26 QUIT
DELCONT(RET,DFN,INP) ;EP-
+1 NEW RET,SIEN,DIE,DA,IEN,APCDY,APCDCM,IENS,FDA,REA,COMM
+2 SET RET=""
+3 IF 'DFN
QUIT
+4 IF $PIECE(INP,U,1)=""
QUIT
+5 ;K DIC,DA,DR
+6 SET APCDY=$PIECE(INP,U,1)
+7 SET REA=$PIECE(INP,U,7)
+8 SET COMM=$PIECE(INP,U,8)
+9 IF REA=""
SET REA="ENTERED IN ERROR"
+10 ;S DA=APCDY,DA(1)=DFN,DR=".01///@"
+11 ;S DIE="^AUPNREP("_DFN_",2101,"
+12 ;D ^DIE
+13 SET SIEN=APCDY_","_DFN_","
+14 SET FDA(9000017.02101,SIEN,1.01)=DUZ
+15 SET FDA(9000017.02101,SIEN,1.02)=$$NOW^XLFDT
+16 SET FDA(9000017.02101,SIEN,1.03)=REA
+17 SET FDA(9000017.02101,SIEN,1.04)=COMM
+18 DO FILE^DIE("","FDA","ERR")
+19 SET DA=APCDY
SET DA(1)=DFN
DO MULTOSET^APCDRF
+20 KILL DA
+21 DO EVT^BGOREP(DFN,2)
+22 QUIT
