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

BGOREP1.m

Go to the documentation of this file. 
  1. 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
  1.  ; Returns reproductive history as a single string
  1.  ; Patch 5 updates the expanded history logic to prevent error on an empty element.
  1.  ; Patch 6 updates to use new field formats for repro history
  1. LAC(RET,CNT,DFN) ;EP get lactation data
  1.  N REP,LAC,LACDT,LACPR
  1.  S REP=$G(^AUPNREP(DFN,2))
  1.  S LAC=$$EXTERNAL^DILFD(FNUM,2.01,,$P(REP,U,1))
  1.  S LACDT=$P(REP,U,2)
  1.  S LACDT=$$FMTDATE^BGOUTL(LACDT)
  1.  S LACPR=$$EXTERNAL^DILFD(FNUM,2.03,,$P(REP,U,3))
  1.  S CNT=CNT+1
  1.  S @RET@(CNT)="B"_U_LAC_U_LACPR_U_LACDT
  1.  Q
  1. MEN(RET,CNT,DFN) ;get menstrual data
  1.  N REP,MA,CA,MENO,DES,DESDT,MAD,CAD,MENOD
  1.  S REP=$G(^AUPNREP(DFN,11))
  1.  S MA=$$EXTERNAL^DILFD(FNUM,1117,,$P(REP,U,17))
  1.  S MAD=$P(REP,U,18)
  1.  S MAD=$$FMTDATE^BGOUTL(MAD)
  1.  S CA=$$EXTERNAL^DILFD(FNUM,1119,,$P(REP,U,19))
  1.  S CAD=$P(REP,U,20)
  1.  S CAD=$$FMTDATE^BGOUTL(CAD)
  1.  S MENO=$$EXTERNAL^DILFD(FNUM,1121,,$P(REP,U,21))
  1.  S MENOD=$P(REP,U,22)
  1.  S MENOD=$$FMTDATE^BGOUTL(MENOD)
  1.  S CNT=CNT+1
  1.  S @RET@(CNT)="M"_U_MA_U_MAD_U_CA_U_CAD_U_MENO_U_MENOD
  1.  S DES=$$EXTERNAL^DILFD(FNUM,1127,,$P(REP,U,27))
  1.  S DESDT=$P($G(^AUPNREP(DFN,11)),U,28)
  1.  S DESDT=$$FMTDATE^BGOUTL(DESDT)
  1.  S CNT=CNT+1
  1.  S @RET@(CNT)="D"_U_DES_U_DESDT
  1.  Q
  1. EDD(RET,CNT,DFN) ;Get pregnancy data
  1.  N REP,LMP,LMPPR,LMPDT,ULTRA,ULTPR,ULTDT,CLIN,CLINPR,CLINDT,UN,UNPR,UNDT,EDD,EDDPR,EDDDT
  1.  N PREG,PREGDT,PREGPR,LMPCO,ULTCO,DEFCO,UNCO,CLINCO,EDDCO
  1.  S REP=$G(^AUPNREP(DFN,13))
  1.  S PREG=$P($G(^AUPNREP(DFN,11)),U,1)
  1.  S PREG=$$EXTERNAL^DILFD(FNUM,1101,,PREG)
  1.  S PREGDT=$P($G(^AUPNREP(DFN,11)),U,2)
  1.  S PREGDT=$$FMTDATE^BGOUTL(PREGDT)
  1.  S PREGPR=$P($G(^AUPNREP(DFN,11)),U,35)
  1.  S PREGPR=$$EXTERNAL^DILFD(FNUM,1304,,PREGPR)
  1.  ;EDD by LMP
  1.  S LMP=$P(REP,U,2)
  1.  S LMP=$$FMTDATE^BGOUTL(LMP)
  1.  S LMPDT=$P(REP,U,3)
  1.  S LMPDT=$$FMTDATE^BGOUTL(LMPDT)
  1.  S LMPPR=$$EXTERNAL^DILFD(FNUM,1304,,$P(REP,U,4))
  1.  S LMPCO=$P($G(^AUPNREP(DFN,14)),U,1)
  1.  ;EDD by ultrasound
  1.  S ULTRA=$P(REP,U,5)
  1.  S ULTRA=$$FMTDATE^BGOUTL(ULTRA)
  1.  S ULTDT=$P(REP,U,6)
  1.  S ULTDT=$$FMTDATE^BGOUTL(ULTDT)
  1.  S ULTPR=$$EXTERNAL^DILFD(FNUM,1307,,$P(REP,U,7))
  1.  S ULTCO=$P($G(^AUPNREP(DFN,14)),U,2)
  1.  ;EDD by clinical parameters
  1.  S CLIN=$P(REP,U,8)
  1.  S CLIN=$$FMTDATE^BGOUTL(CLIN)
  1.  S CLINDT=$P(REP,U,9)
  1.  S CLINDT=$$FMTDATE^BGOUTL(CLINDT)
  1.  S CLINPR=$$EXTERNAL^DILFD(FNUM,1310,,$P(REP,U,10))
  1.  S CLINCO=$P($G(^AUPNREP(DFN,15)),U,1)
  1.  S EDD=$P(REP,U,11)
  1.  S EDD=$$FMTDATE^BGOUTL(EDD)
  1.  ;S EDD=$$EXTERNAL^DILFD(FNUM,1311,,$P(REP,U,11))
  1.  S EDDDT=$P(REP,U,12)
  1.  S EDDDT=$$FMTDATE^BGOUTL(EDDDT)
  1.  S EDDPR=$$EXTERNAL^DILFD(FNUM,1313,,$P(REP,U,13))
  1.  S EDDCO=$P($G(^AUPNREP(DFN,15)),U,2)
  1.  ;EDD by unknown methods
  1.  S UN=$P(REP,U,14)
  1.  S UN=$$FMTDATE^BGOUTL(UN)
  1.  S UNDT=$P(REP,U,15)
  1.  S UNDT=$$FMTDATE^BGOUTL(UNDT)
  1.  S UNPR=$$EXTERNAL^DILFD(FNUM,1316,,$P(REP,U,16))
  1.  S UNCO=$P($G(^AUPNREP(DFN,16)),U,1)
  1.  S CNT=CNT+1
  1.  S @RET@(CNT)="P"_U_PREG_U_PREGPR_U_PREGDT
  1.  S CNT=CNT+1
  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
  1.  Q
  1. CONT(RET,CNT,DFN) ; Get contraceptive data
  1.  N I,NODE,NAME,CNAME,CHK,CBEGUN,STRING,REC,FNUM
  1.  S STRING="",CHK=0
  1.  S I=0 F  S I=$O(^AUPNREP(DFN,2101,I)) Q:I=""!('+I)  D
  1.  .S NODE=$G(^AUPNREP(DFN,2101,I,0))
  1.  .Q:$D(^AUPNREP(DFN,2101,I,1))>0
  1.  .S CHK=CHK+1
  1.  .I $P(NODE,U,3)="" D
  1.  ..S NAME=$P(NODE,U,1),CBEGUN=$P(NODE,U,2)
  1.  ..S CBEGUN=$$FMTDATE^BGOUTL(CBEGUN)
  1.  ..S CNAME=$P($G(^AUTTCM(NAME,0)),U,1)
  1.  ..I CNAME="OTHER" S CNAME=CNAME_"-"_$P(NODE,U,6)
  1.  ..I STRING="" S STRING=CNAME_";"_CBEGUN
  1.  ..E  S STRING=STRING_"^"_CNAME_";"_CBEGUN
  1.  I CHK=0 D
  1.  .;S FNUM=$$FNUM^BGOREP
  1.  .;S REC=$G(^AUPNREP(DFN,0))
  1.  .;S CNAME=$$EXTERNAL^DILFD(FNUM,3,,$P(REC,U,6))
  1.  .;S CBEGUN=$P(REC,U,7)
  1.  .;S CBEGUN=$$FMTDATE^BGOUTL(CBEGUN)
  1.  .;I CNAME'="" S STRING=CNAME_";"_CBEGUN
  1.  S CNT=CNT+1
  1.  S @RET@(CNT)="C"_U_STRING
  1.  Q
  1. CONTALL(RET,DFN) ;EP for RPC call to get all contrceptive data
  1.  ; Input DFN of patient
  1.  ;Output string:
  1.  ;IEN of subfile [1] ^ method [2] ^ date started [3] ^ date ended [4] ^ reason DC [5] ^ comment [6]
  1.  N CNT,NODE,I,J,NAME,CNAME,BEGUN,CDATE,STRING,ARRAY,CEND,COMM,CREA
  1.  K ARRAY
  1.  S RET=$$TMPGBL^BGOUTL
  1.  S STRING="",CNT=0
  1.  S I=0 F  S I=$O(^AUPNREP(DFN,2101,I)) Q:I=""!('+I)  D
  1.  .Q:$D(^AUPNREP(DFN,2101,I,1))>0
  1.  .S NODE=$G(^AUPNREP(DFN,2101,I,0))
  1.  .I NODE'="" D
  1.  ..S NAME=$P(NODE,U,1)
  1.  ..S CDATE=$P(NODE,U,2)
  1.  ..S CBEGUN=$$FMTDATE^BGOUTL(CDATE)
  1.  ..S CNAME=$P($G(^AUTTCM(NAME,0)),U,1)
  1.  ..S CEND=$P(NODE,U,3)
  1.  ..S CEND=$$FMTDATE^BGOUTL(CEND)
  1.  ..S CREA=$P(NODE,U,5)
  1.  ..S COMM=$P(NODE,U,6)
  1.  ..S ARRAY(9999999-CDATE,I)=I_U_CNAME_U_CBEGUN_U_CEND_U_CREA_U_COMM
  1.  I '$D(ARRAY) S @RET@(1)="" Q
  1.  I $D(ARRAY)>0 D
  1.  .S I=0 F  S I=$O(ARRAY(I)) Q:I=""  D
  1.  ..S J=0 F  S J=$O(ARRAY(I,J)) Q:J=""  D
  1.  ...S CNT=CNT+1
  1.  ...S @RET@(CNT)=$G(ARRAY(I,J))
  1.  Q
  1.  ;Set items into the contracepton multiple
  1.  ;Input= DFN - patient
  1.  ;DATA= array of items to be edited/stored in this format
  1.  ;  (n)= IEN of subfile (if edit) [1] ^ Type of contraception [2] ^ date start [3] ^ date end [4] ^ reason DC [5] ^ comment [6]
  1. SETCONT(RET,DFN,DATA) ;EP
  1.  N I,FNUM,NEW,AIEN,IENS,NODE,CON,CONB,CIEN,CONE,CONDC,COM,TODAY,FDA,IEN,ERR
  1.  S RET="",FNUM=$$FNUM^BGOREP
  1.  S TODAY=$$DT^XLFDT
  1.  S DFN=+DFN
  1.  I '$D(^DPT(DFN,0)) S RET=$$ERR^BGOUTL(1001) Q
  1.  I $P(^DPT(DFN,0),U,2)'="F" S RET=$$ERR^BGOUTL(1052) Q
  1.  S NEW='$D(^AUPNREP(DFN))
  1.  I NEW D
  1.  .S IENS="+1,"
  1.  .S FDA(9000017,"+1,",.01)=DFN
  1.  .S IEN(1)=DFN
  1.  .S FDA(9000017,"+1,",1.1)=TODAY
  1.  .D UPDATE^DIE("","FDA","IEN","ERR")
  1.  .I $D(IEN(1)) S RET=""
  1.  .I $D(ERR) S RET="Unable to store patient"
  1.  S I="" F  S I=$O(DATA(I)) Q:I=""!(RET'="")  D
  1.  .K FDA
  1.  .S NODE=$G(DATA(I))
  1.  .S FNUM=9000017.02101
  1.  .Q:$P(NODE,U,2)=""
  1.  .I $P(NODE,U,1)="" D NEW Q
  1.  .E  S AIEN=$P(NODE,U,1)_","_DFN_","
  1.  .S FDA=$NA(FDA(FNUM,AIEN))
  1.  .S CON=$P(NODE,U,2)
  1.  .S:$L(CON) @FDA@(.01)=CON
  1.  .S CONB=$$SDATE($P(NODE,U,3))
  1.  .S:$L(CONB) @FDA@(.02)=CONB
  1.  .S CONE=$$SDATE($P(NODE,U,4))
  1.  .I CONE="" S CONE="@"
  1.  .S @FDA@(.03)=CONE
  1.  .S @FDA@(.04)=$$FMTE^XLFDT(DT)
  1.  .S CONDC=$P(NODE,U,5)
  1.  .S:$L(CONDC) @FDA@(.05)=CONDC
  1.  .S COM=$P(NODE,U,6)
  1.  .S:$L(COM) @FDA@(.06)=COM
  1.  .S RET=$$UPDATE^BGOUTL(.FDA,"E@")
  1.  .D:'$D(ERR) EVT^BGOREP(DFN,1)
  1.  S:'$D(ERR) RET=DFN
  1.  Q
  1. SDATE(IDATE) ;Format date
  1.  N DATA,MO,DAY
  1.  S DAY=$E(IDATE,4,5)
  1.  S MO=$E(IDATE,1,2)
  1.  I DAY="00"&(MO="00") S DATA=$E(IDATE,7,10) Q DATA
  1.  I DAY="00" S DATA=MO_"/"_$E(IDATE,7,10) Q DATA
  1.  E  S DATA=IDATE
  1.  Q DATA
  1. NEW ;Add new one
  1.  N APCDCMI,APCDREPI,DA,DIC,DIE,X,CON,CONB,CONE,COM,CONDC
  1.  S APCDREPI=DFN
  1.  S CON=$P(NODE,U,2)
  1.  S CON=$O(^AUTTCM("B",CON,""))
  1.  Q:CON=""
  1.  S DIC(0)="AEMQ"
  1.  S DIC="^AUPNREP("_APCDREPI_",2101,"
  1.  S DA(1)=APCDREPI
  1.  S DIC("P")=$P(^DD(9000017,2101,0),U,2)
  1.  S X=CON
  1.  S DIE("NO^")=1
  1.  S DIC("DR")=""
  1.  K DD,D0,DO
  1.  D FILE^DICN
  1.  S CONB=$P(NODE,U,3)
  1.  S CONE=$P(NODE,U,4)
  1.  I CONE="" S CONE="@"
  1.  S CONDC=$P(NODE,U,5)
  1.  S COM=$P(NODE,U,6)
  1.  S DIE("NO^")=1
  1.  S (APCDY,DA)=+Y,DA(1)=APCDREPI,DR=".02///"_CONB_";.03///"_CONE_";.04///^S X=$$FMTE^XLFDT(DT)"_";.05///"_CONDC_";.06///"_COM
  1.  S DIE="^AUPNREP("_APCDREPI_",2101,",DIE("NO^")=1
  1.  D ^DIE
  1.  K DIE,DR,DA
  1.  D EVT^BGOREP(DFN,1)
  1.  Q
  1. DELCONT(RET,DFN,INP) ;EP-
  1.  N RET,SIEN,DIE,DA,IEN,APCDY,APCDCM,IENS,FDA,REA,COMM
  1.  S RET=""
  1.  Q:'DFN
  1.  Q:$P(INP,U,1)=""
  1.  ;K DIC,DA,DR
  1.  S APCDY=$P(INP,U,1)
  1.  S REA=$P(INP,U,7)
  1.  S COMM=$P(INP,U,8)
  1.  I REA="" S REA="ENTERED IN ERROR"
  1.  ;S DA=APCDY,DA(1)=DFN,DR=".01///@"
  1.  ;S DIE="^AUPNREP("_DFN_",2101,"
  1.  ;D ^DIE
  1.  S SIEN=APCDY_","_DFN_","
  1.  S FDA(9000017.02101,SIEN,1.01)=DUZ
  1.  S FDA(9000017.02101,SIEN,1.02)=$$NOW^XLFDT
  1.  S FDA(9000017.02101,SIEN,1.03)=REA
  1.  S FDA(9000017.02101,SIEN,1.04)=COMM
  1.  D FILE^DIE("","FDA","ERR")
  1.  S DA=APCDY,DA(1)=DFN D MULTOSET^APCDRF
  1.  K DA
  1.  D EVT^BGOREP(DFN,2)
  1.  Q