Routine: BSDX41E

BSDX41E ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;

 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010

OFFHX ; ********** OFFSPRING HISTORY * 9000012 **********

 ; <SETUP>

 Q:$P(^DPT(APCHSPAT,0),U,2)'="F"

 Q:'$D(^AUPNOFFH("AA",APCHSPAT))

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 X APCHSCKP Q:$D(APCHSQIT)  D OFFHDR

 ; <DISPLAY>

 S APCHSDAT=0 F APCHSQ=0:0 S APCHSDAT=$O(^AUPNOFFH("AA",APCHSPAT,APCHSDAT)) Q:'APCHSDAT  S APCHSDFN=0 F APCHSQ=0:0 S APCHSDFN=$O(^AUPNOFFH("AA",APCHSPAT,APCHSDAT,APCHSDFN)) Q:'APCHSDFN  D OFFDSP Q:$D(APCHSQIT)

OFFHXX K APCHSDAT,APCHSDFN,APCHSN,APCHSP,X,Y

OFFDSP ;

 S APCHSN=^AUPNOFFH(APCHSDFN,0)

 X APCHSCKP Q:$D(APCHSQIT)  D:APCHSNPG OFFHDR

 S Y=APCHSDAT X APCHSCVD

 S BSDXDSP=Y_$$FILL^BSDX41(10-$L(Y))_$P(APCHSN,U,4)

 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(20-$L(BSDXDSP))_$P(APCHSN,U,5)

 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(24-$L(BSDXDSP))_$J(+$P(APCHSN,U,6),5,2)

 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(31-$L(BSDXDSP))_$P(APCHSN,U,7)

 I $P(APCHSN,U,8) S BSDXDSP=BSDXDSP_$$FILL^BSDX41(35-$L(BSDXDSP))_$P(APCHSN,U,8)_"/"_$S($P(APCHSN,U,9):$P(APCHSN,U,9),1:"-")

 I $P(APCHSN,U,11) S Y=$P(APCHSN,U,11) X APCHSCVD S Y="("_Y_$S($P(APCHSN,U,12)]"":": "_$P(APCHSN,U,12),1:"")_")" S BSDXDSP=BSDXDSP_$$FILL^BSDX41(42-$L(BSDXDSP))_$E(Y,1,36)

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)

PNC I $O(^AUPNOFFH(APCHSDFN,21,0)) D

 . S BSDXDSP="         "_"PERINATAL COMPLICATION: "

 . S APCHSP=0

 . F  S APCHSP=$O(^AUPNOFFH(APCHSDFN,21,APCHSP)) Q:'APCHSP  S Y=^(APCHSP,0) D OUTC Q:$D(APCHSQIT)

 . S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)

 Q:$D(APCHSQIT)

NNC I $O(^AUPNOFFH(APCHSDFN,31,0)) D

 . S BSDXDSP="         "_"NEONATAL COMPLICATION: "

 . S APCHSP=0

 . F  S APCHSP=$O(^AUPNOFFH(APCHSDFN,31,APCHSP)) Q:'APCHSP  S Y=^(APCHSP,0) D OUTC Q:$D(APCHSQIT)

 . S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)

OFFHDR S BSDXDSP="DOB"

 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(10_$L(BSDXDSP))_"NAME"

 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(20-$L(BSDXDSP))_"SEX"

 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(25-$L(BSDXDSP))_"BWT"

 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(31-$L(BSDXDSP))_"EGA"

 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(35-$L(BSDXDSP))_"APGAR"

 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(42-$L(BSDXDSP))_"DEATH"

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)

OUTC X APCHSCKP Q:$D(APCHSQIT)  D:APCHSNPG OFFHDR

 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(34-$L(BSDXDSP))_Y_$C(10,13)

REPHX ; ********** REPRODUCTIVE HISTORY * 9000017 **********

 ; <SETUP>

 Q:$P(^DPT(APCHSPAT,0),U,2)'="F"

 Q:'$D(^AUPNREP(APCHSPAT))

 S APCHSN=^AUPNREP(APCHSPAT,0)

 I $D(^DD(9000017,2101)) D NEWREP G REPHXX

 ; <DISPLAY>

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 S X=$P(APCHSN,U,2) I X]"" S BSDXTMP=X S APCHSP=3 D DTOBT S BSDXTMP=BSDXTMP_"  "

 S X=$P(APCHSN,U,4) S:X="" X="<not recorded>" S Y=X X:+X APCHSCVD S BSDXTMP=BSDXTMP_"LMP "_Y S APCHSP=5 D DTOBT S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)

 S X=$P(APCHSN,U,6) I X]""

 S Y=$P(^DD(9000017,3,0),U,3),X=$P(Y,";",X+1)

 S APCHSM=$P(X,":",2)

 X APCHSCKP

 G:$D(APCHSQIT) REPHXX

 S BSDXTMP="CONTRACEPTION: "_APCHSM

 S X=$P(APCHSN,U,7)

 X:+X "S Y=X X APCHSCVD S BSDXTMP=BSDXTMP_"", EFFECTIVE ""_Y"

 S APCHSP=8

 D DTOBT

 S BSDXI=BSDXI+1

 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)

 S X=$P(APCHSN,U,9) I X]"" X APCHSCKP G:$D(APCHSQIT) REPHXX D EDC

REPHXX K APCHSN,APCHSM,APCHSN11

NEWREP ;new reproductive factors dd

 S APCHSN11=$G(^AUPNREP(APCHSPAT,0))

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 S X=$$RHX^AUPNREP(APCHSPAT) I X]""

 . S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)

 . S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="Reproductive History: "_$C(30)

 . S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=" "_$P(X,";",1,4)_";"_$C(30)

 . S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="  "_$P(X,";",5,7)_$C(30)

 . S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="  "_";"_$P(X,";",8,99)_$C(30)

 X APCHSCKP Q:$D(APCHSQIT)  ;X:'APCHSNPG APCHSBRK

 S X=$P(APCHSN,U,4) I X]"" S BSDXTMP="LMP: " S Y=X X APCHSCVD S BSDXTMP=BSDXTMP_Y S APCHSP=5 D DTOBT S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)

 S X=$P(APCHSN,U,6) I X]""

 S Y=$P(^DD(9000017,3,0),U,3),X=$P(Y,";",X+1)

 S APCHSM=$P(X,":",2)

 X APCHSCKP

 G:$D(APCHSQIT) REPHXX

 S BSDXTMP="CONTRACEPTION: "_APCHSM

 S X=$P(APCHSN,U,7)

 X:+X "S Y=X X APCHSCVD S BSDXTMP=BSDXTMP_"", EFFECTIVE ""_Y"

 S APCHSP=8

 D DTOBT

 S BSDXI=BSDXI+1

 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)

 S X=$P(APCHSN,U,9) I X]"" X APCHSCKP G:$D(APCHSQIT) REPHXX D EDC

LATER ;

 I $O(^AUPNREP(APCHSPAT,2101,0)) D

 .X APCHSCKP Q:$D(APCHSQIT)  ;X:'APCHSNPG APCHSBRK

 .S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)

 .S BSDXDSP="  "_"Contraceptive Method"

 .S BSDXDSP=BSDXDSP_$$FILL^BSDX41(40-$L(BSDXDSP))_"Date Started"

 .S BSDXDSP=BSDXDSP_$$FILL^BSDX41(55-$L(BSDXDSP))_"Date Ended"

 .S APCHX=0 F  S APCHX=$O(^AUPNREP(APCHSPAT,2101,APCHX)) Q:APCHX'=+APCHX  D

 ..S APCHC=$P(^AUPNREP(APCHSPAT,2101,APCHX,0),U,1) I APCHC D

 ...X APCHSCKP Q:$D(APCHSQIT)  ;X:'APCHSNPG APCHSBRK

 ...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)

 ...S BSDXDSP="    "_$P(^AUTTCM(APCHC,0),U)

 ...S Y=$P(^AUPNREP(APCHSPAT,2101,APCHX,0),U,2) I Y]"" X APCHSCVD S BSDXDSP=BSDXDSP_$$FILL^BSDX41(40-$L(BSDXDSP))_Y

 ...S Y=$P(^AUPNREP(APCHSPAT,2101,APCHX,0),U,3) I Y]"" X APCHSCVD S BSDXDSP=BSDXDSP_$$FILL^BSDX41(55-$L(BSDXDSP))_Y

 .S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)

DTOBT S Y=$P(APCHSN,U,APCHSP) I Y]"" X APCHSCVD S BSDXTMP=" (obtained "_Y_")"

EDC S Y=$P(APCHSN,U,9)

 X APCHSCVD S BSDXTMP="*** NOTE: EDC "_Y S APCHSP=11 D DTOBT

 I X<DT S BSDXTMP=BSDXTMP_" -- OUTDATED!"

 E  S X=$P(APCHSN,U,10),APCHSM="UNKNOWN METHOD" S:X Y=$P(^DD(9000017,4.05,0),U,3),X=$P(Y,";",X+1),APCHSM=$P(X,":",2)  S BSDXTMP=BSDXTMP_" BY "_APCHSM

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)

TRTMT ; ********** TREATMENTS * 9000010.15 **********

 ; <SETUP>

 Q:'$D(^AUPNVTRT("AA",APCHSPAT))

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 ; <DISPLAY>

 S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVTRT("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDTT=Y S APCHSDTU=0 D ONEDATE Q:$D(APCHSQIT)  S APCHSNDM=APCHSNDM-APCHSDTU Q:APCHSNDM=0

 ; <CLEANUP>

TRTMTX K APCHSVDF,APCHSIVD,APCHSDTU,APCHSDTT,APCHSDFN,APCHSFO,APCHSFAC,APCHSNT,APCHST,APCHSLVL,APCHSLVT,APCHSN

 K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE

ONEDATE S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVTRT("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:APCHSDFN=""  D TRTCHK Q:$D(APCHSQIT)

TRTCHK S APCHSN=^AUPNVTRT(APCHSDFN,0)

 Q:'$P(^AUTTTRT($P(APCHSN,U,1),0),U,3)

 S APCHSVDF=$P(APCHSN,U,3) D GETSITEV^APCHSUTL Q:"ADTC"'[APCHSVSC

 X APCHSCKP Q:$D(APCHSQIT)  S:APCHSNPG APCHSDTU=0

 S BSDXTMP=""

 I 'APCHSDTU S BSDXTMP=APCHSDTT S APCHSFO=""

 I APCHSNSH=APCHSFO S APCHSFAC=""

 E  S (APCHSFAC,APCHSFO)=APCHSNSH

 S APCHSDTU=1

 S APCHST=$P(APCHSN,U,1),APCHST=$P(^AUTTTRT(APCHST,0),U,1)

 S APCHSNT=+$P(APCHSN,U,4)

 S APCHSLVL=$P(APCHSN,U,6),APCHSLVT=""

 I APCHSLVL]"" S APCHSLVT=$P(^DD(9000010.15,.06,0),U,3),APCHSLVT=$P($P(APCHSLVT,APCHSLVL_":",2),";",1),APCHSLVT=" - "_$P(APCHSLVT,",",1)_" UNDERSTANDING"

 X APCHSCKP Q:$D(APCHSQIT)  I APCHSNPG D

 . S BSDXDSP=APCHSDTT

 . S BSDXDSP=BSDXDSP_$$FILL^BSDX41(10-$L(BSDXDSP))_$E(APCHSFAC,1,10)

 . S BSDXDSP=BSDXDSP_$$FILL^BSDX41(21-$L(BSDXDSP))_APCHST_" ("_APCHSNT_")"_APCHSLVT

 . S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_BSDXDSP_$C(30)

TXC ;EP - called from component

 ; <SETUP>

 Q:'$D(^AUPNVTXC("AA",APCHSPAT))

 X APCHSBRK

 ; <DISPLAY>

 S APCHST="" F APCHSQ=0:0 S APCHST=$O(^AUPNVTXC("AA",APCHSPAT,APCHST)) Q:APCHST=""  S APCHSTX=$$EXTSET^XBFUNC(9000010.39,.01,APCHST),APCHSTL=$L(APCHSTX) X APCHSCKP Q:$D(APCHSQIT)  D TXDSP6

 ; <CLEANUP>

TXCX K APCHST,APCHSTX,APCHSTL,APCHSIVD,APCHSDFN,APCHSDI,APCHSVDF,APCHSDAT,APCHSCNT,APCHS,X,Y

 K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE

TXDSP6 ;get contract type

 S APCHSCNT=0

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)

 X APCHSCKP Q:$D(APCHSQIT)

 S BSDXDSP=BSDXDSP_APCHSTX

 S APCHSIVD=""

 F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVTXC("AA",APCHSPAT,APCHST,APCHSIVD)) S APCHSCNT=APCHSCNT+1 Q:APCHSIVD=""!(APCHSCNT>6)  D TXDSP13

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)

TXDSP13 ;

 S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y

 S APCHSDFN=0 F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVTXC("AA",APCHSPAT,APCHST,APCHSIVD,APCHSDFN)) Q:'APCHSDFN!(APCHSCNT>6)  D TXDSP23

TXDSP23 ;

 S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y

 S APCHSVDF=$P(^AUPNVTXC(APCHSDFN,0),U,3)

 S APCHSDI=$$VAL^XBDIQ1(9000010.39,APCHSDFN,.04)

 S APCHSPI=$$VAL^XBDIQ1(9000010.39,APCHSDFN,.05)

 X APCHSCKP Q:$D(APCHSQIT)  I APCHSNPG D

 . S BSDXDSP=BSDXDSP_APCHSTX

 . S BSDXDSP=BSDXDSP_$$FILL^BSDX41(20-$L(BSDXDSP))_APCHSDI

 . S BSDXDSP=BSDXDSP_$$FILL^BSDX41(40-$L(BSDXDSP))_APCHSPI_$C(10,13)

BIRTHM ; ********** BIRTH MEASUREMENTS 9000024 AND V INFANT FEEDING 9000010.44 **********

 ; <SETUP>

 I '$D(^AUPNBMSR("B",APCHSPAT)),'$O(^AUPNVIF("AC",APCHSPAT,0)) Q

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 ; <DISPLAY>

 S APCHX=$G(^AUPNBMSR(APCHSPAT,0))

 S BSDXDSP="BIRTH WEIGHT (kg)"

 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(30-$L(BSDXDSP))_$P(APCHX,U,18)

 S BSDXTMP=BSDXDSP

 X APCHSCKP Q:$D(APCHSQIT)

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)

 S BSDXDSP="BIRTH ORDER" S X=$P(APCHX,U,11) S:X["W" X=+X_" weeks" S:X["D" X=+X_" days" S:X["M" X=+X_" months" S:X["Y" X=+X_" years" S BSDXDSP=BSDXDSP_$$FILL^BSDX41(30-$L(BSDXDSP))_X

 S BSDXTMP=BSDXDSP

 X APCHSCKP Q:$D(APCHSQIT)

 S X=$P(APCHX,U,12)

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)

 S BSDXDSP="FORMULA STARTED (age)" S:X["W" X=+X_" weeks" S:X["D" X=+X_" days" S:X["M" X=+X_" months" S:X["Y" X=+X_" years" S BSDXDSP=BSDXDSP_$$FILL^BSDX41(30-$L(BSDXDSP))_X

 S BSDXTMP=BSDXDSP

 X APCHSCKP Q:$D(APCHSQIT)

 S X=$P(APCHX,U,14)

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)

 S BSDXDSP="BREAST STOPPED (age)" S:X["W" X=+X_" weeks" S:X["D" X=+X_" days" S:X["M" X=+X_" months" S:X["Y" X=+X_" years" S BSDXDSP=BSDXDSP_$$FILL^BSDX41(30-$L(BSDXDSP))_X

 S BSDXTMP=BSDXDSP

 X APCHSCKP Q:$D(APCHSQIT)

 S X=$P(APCHX,U,16)

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)

 S BSDXDSP="SOLIDS BEGUN (age)" S:X["W" X=+X_" weeks" S:X["D" X=+X_" days" S:X["M" X=+X_" months" S:X["Y" X=+X_" years" S BSDXDSP=BSDXDSP_$$FILL^BSDX41(30-$L(BSDXDSP))_X

 S BSDXTMP=BSDXDSP

 Q:'$O(^AUPNVIF("AC",APCHSPAT,0))

 K APCHT S APCHX=0 F  S APCHX=$O(^AUPNVIF("AC",APCHSPAT,APCHX)) Q:APCHX'=+APCHX  D

 .S V=$P(^AUPNVIF(APCHX,0),U,3)

 .Q:'V

 .S V=$P($P($G(^AUPNVSIT(V,0)),U),".")

 .Q:V=""

 .S APCHT(V,APCHX)=$$AGE^AUPNPAT(APCHSPAT,V,"E")_U_$$VAL^XBDIQ1(9000010.44,APCHX,.01)

.Q

 ;write out data

 X APCHSCKP Q:$D(APCHSQIT)

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)

 S BSDXDSP="VISIT DATE"

 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(20-$L(BSDXDSP))_"AGE"

 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(32-$L(BSDXDSP))_"FEEDING CHOICE"

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)

 S APCHD=0 F  S APCHD=$O(APCHT(APCHD)) Q:APCHD'=+APCHD!($D(APCHSQIT))  S APCHX=0 F  S APCHX=$O(APCHT(APCHD,APCHX)) Q:APCHX'=+APCHX!($D(APCHSQIT))  D

 .X APCHSCKP Q:$D(APCHSQIT)

 .S BSDXDSP=$$DATE^APCHSMU(APCHD)

 .S BSDXDSP=BSDXDSP_$$FILL^BSDX41(20-$L(BSDXDSP))_$P(APCHT(APCHD,APCHX),U)

 .S BSDXDSP=BSDXDSP_$$FILL^BSDX41(32-$L(BSDXDSP))_$P(APCHT(APCHD,APCHX),U,2)

 .S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)

.Q

BRTHX K APCHSDAT,APCHSDFN,APCHSN,APCHSP,X,Y,APCHX,APCHT,APCHD

BSDX41E   ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;

 +1       ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010

 +2       ;

OFFHX     ; ********** OFFSPRING HISTORY * 9000012 **********

 +1       ; <SETUP>

 +2        IF $PIECE(^DPT(APCHSPAT,0),U,2)'="F"

               QUIT

 +3        IF '$DATA(^AUPNOFFH("AA",APCHSPAT))

               QUIT

 +4        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

           IF 'APCHSNPG

               XECUTE APCHSBRK

 +5        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

           DO OFFHDR

 +6       ; <DISPLAY>

 +7        SET APCHSDAT=0

           FOR APCHSQ=0:0

               SET APCHSDAT=$ORDER(^AUPNOFFH("AA",APCHSPAT,APCHSDAT))

               IF 'APCHSDAT

                   QUIT

               SET APCHSDFN=0

               FOR APCHSQ=0:0

                   SET APCHSDFN=$ORDER(^AUPNOFFH("AA",APCHSPAT,APCHSDAT,APCHSDFN))

                   IF 'APCHSDFN

                       QUIT

                   DO OFFDSP

                   IF $DATA(APCHSQIT)

                       QUIT

OFFHXX     KILL APCHSDAT,APCHSDFN,APCHSN,APCHSP,X,Y

 +1        QUIT

OFFDSP    ;

 +1        SET APCHSN=^AUPNOFFH(APCHSDFN,0)

 +2        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

           IF APCHSNPG

               DO OFFHDR

 +3        SET Y=APCHSDAT

           XECUTE APCHSCVD

 +4        SET BSDXDSP=Y_$$FILL^BSDX41(10-$LENGTH(Y))_$PIECE(APCHSN,U,4)

 +5        SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(20-$LENGTH(BSDXDSP))_$PIECE(APCHSN,U,5)

 +6        SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(24-$LENGTH(BSDXDSP))_$JUSTIFY(+$PIECE(APCHSN,U,6),5,2)

 +7        SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(31-$LENGTH(BSDXDSP))_$PIECE(APCHSN,U,7)

 +8        IF $PIECE(APCHSN,U,8)

               SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(35-$LENGTH(BSDXDSP))_$PIECE(APCHSN,U,8)_"/"_$SELECT($PIECE(APCHSN,U,9):$PIECE(APCHSN,U,9),1:"-")

 +9        IF $PIECE(APCHSN,U,11)

               SET Y=$PIECE(APCHSN,U,11)

               XECUTE APCHSCVD

               SET Y="("_Y_$SELECT($PIECE(APCHSN,U,12)]"":": "_$PIECE(APCHSN,U,12),1:"")_")"

               SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(42-$LENGTH(BSDXDSP))_$EXTRACT(Y,1,36)

 +10       SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)=BSDXDSP_$CHAR(30)

PNC        IF $ORDER(^AUPNOFFH(APCHSDFN,21,0))

               Begin DoDot:1

 +1                SET BSDXDSP="         "_"PERINATAL COMPLICATION: "

 +2                SET APCHSP=0

 +3                FOR

                       SET APCHSP=$ORDER(^AUPNOFFH(APCHSDFN,21,APCHSP))

                       IF 'APCHSP

                           QUIT

                       SET Y=^(APCHSP,0)

                       DO OUTC

                       IF $DATA(APCHSQIT)

                           QUIT

 +4                SET BSDXI=BSDXI+1

                   SET ^BSDXTMP($JOB,BSDXI)=BSDXDSP_$CHAR(30)

               End DoDot:1

 +5        IF $DATA(APCHSQIT)

               QUIT

NNC        IF $ORDER(^AUPNOFFH(APCHSDFN,31,0))

               Begin DoDot:1

 +1                SET BSDXDSP="         "_"NEONATAL COMPLICATION: "

 +2                SET APCHSP=0

 +3                FOR

                       SET APCHSP=$ORDER(^AUPNOFFH(APCHSDFN,31,APCHSP))

                       IF 'APCHSP

                           QUIT

                       SET Y=^(APCHSP,0)

                       DO OUTC

                       IF $DATA(APCHSQIT)

                           QUIT

 +4                SET BSDXI=BSDXI+1

                   SET ^BSDXTMP($JOB,BSDXI)=BSDXDSP_$CHAR(30)

               End DoDot:1

 +5        QUIT

OFFHDR     SET BSDXDSP="DOB"

 +1        SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(10_$LENGTH(BSDXDSP))_"NAME"

 +2        SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(20-$LENGTH(BSDXDSP))_"SEX"

 +3        SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(25-$LENGTH(BSDXDSP))_"BWT"

 +4        SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(31-$LENGTH(BSDXDSP))_"EGA"

 +5        SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(35-$LENGTH(BSDXDSP))_"APGAR"

 +6        SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(42-$LENGTH(BSDXDSP))_"DEATH"

 +7        SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)=BSDXDSP_$CHAR(30)

 +8        QUIT

OUTC       XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

           IF APCHSNPG

               DO OFFHDR

 +1        SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(34-$LENGTH(BSDXDSP))_Y_$CHAR(10,13)

 +2        QUIT

 +3       ;

REPHX     ; ********** REPRODUCTIVE HISTORY * 9000017 **********

 +1       ; <SETUP>

 +2        IF $PIECE(^DPT(APCHSPAT,0),U,2)'="F"

               QUIT

 +3        IF '$DATA(^AUPNREP(APCHSPAT))

               QUIT

 +4        SET APCHSN=^AUPNREP(APCHSPAT,0)

 +5        IF $DATA(^DD(9000017,2101))

               DO NEWREP

               GOTO REPHXX

 +6       ; <DISPLAY>

 +7        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

           IF 'APCHSNPG

               XECUTE APCHSBRK

 +8        SET X=$PIECE(APCHSN,U,2)

           IF X]""

               SET BSDXTMP=X

               SET APCHSP=3

               DO DTOBT

               SET BSDXTMP=BSDXTMP_"  "

 +9        SET X=$PIECE(APCHSN,U,4)

           IF X=""

               SET X="<not recorded>"

           SET Y=X

           IF +X

               XECUTE APCHSCVD

           SET BSDXTMP=BSDXTMP_"LMP "_Y

           SET APCHSP=5

           DO DTOBT

           SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)

 +10       SET X=$PIECE(APCHSN,U,6)

           IF X]""

 +11       SET Y=$PIECE(^DD(9000017,3,0),U,3)

           SET X=$PIECE(Y,";",X+1)

 +12       SET APCHSM=$PIECE(X,":",2)

 +13       XECUTE APCHSCKP

 +14       IF $DATA(APCHSQIT)

               GOTO REPHXX

 +15       SET BSDXTMP="CONTRACEPTION: "_APCHSM

 +16       SET X=$PIECE(APCHSN,U,7)

 +17       IF +X

               XECUTE "S Y=X X APCHSCVD S BSDXTMP=BSDXTMP_"", EFFECTIVE ""_Y"

 +18       SET APCHSP=8

 +19       DO DTOBT

 +20       SET BSDXI=BSDXI+1

 +21       SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)

 +22       SET X=$PIECE(APCHSN,U,9)

           IF X]""

               XECUTE APCHSCKP

               IF $DATA(APCHSQIT)

                   GOTO REPHXX

               DO EDC

REPHXX     KILL APCHSN,APCHSM,APCHSN11

 +1        QUIT

 +2       ;

NEWREP    ;new reproductive factors dd

 +1        SET APCHSN11=$GET(^AUPNREP(APCHSPAT,0))

 +2        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

           IF 'APCHSNPG

               XECUTE APCHSBRK

 +3        SET X=$$RHX^AUPNREP(APCHSPAT)

           IF X]""

+4

*** ERROR ***

+5

*** ERROR ***

+6

*** ERROR ***

+7

*** ERROR ***

+8

*** ERROR ***

 +9       ;X:'APCHSNPG APCHSBRK

           XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

 +10       SET X=$PIECE(APCHSN,U,4)

           IF X]""

               SET BSDXTMP="LMP: "

               SET Y=X

               XECUTE APCHSCVD

               SET BSDXTMP=BSDXTMP_Y

               SET APCHSP=5

               DO DTOBT

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)

 +11       SET X=$PIECE(APCHSN,U,6)

           IF X]""

 +12       SET Y=$PIECE(^DD(9000017,3,0),U,3)

           SET X=$PIECE(Y,";",X+1)

 +13       SET APCHSM=$PIECE(X,":",2)

 +14       XECUTE APCHSCKP

 +15       IF $DATA(APCHSQIT)

               GOTO REPHXX

 +16       SET BSDXTMP="CONTRACEPTION: "_APCHSM

 +17       SET X=$PIECE(APCHSN,U,7)

 +18       IF +X

               XECUTE "S Y=X X APCHSCVD S BSDXTMP=BSDXTMP_"", EFFECTIVE ""_Y"

 +19       SET APCHSP=8

 +20       DO DTOBT

 +21       SET BSDXI=BSDXI+1

 +22       SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)

 +23       SET X=$PIECE(APCHSN,U,9)

           IF X]""

               XECUTE APCHSCKP

               IF $DATA(APCHSQIT)

                   GOTO REPHXX

               DO EDC

 +24       QUIT

 +25      ;

LATER     ;

 +1        IF $ORDER(^AUPNREP(APCHSPAT,2101,0))

               Begin DoDot:1

 +2       ;X:'APCHSNPG APCHSBRK

                   XECUTE APCHSCKP

                   IF $DATA(APCHSQIT)

                       QUIT

 +3                SET BSDXI=BSDXI+1

                   SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)

               End DoDot:1

 +4        SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)

+5

*** ERROR ***

+6

*** ERROR ***

+7

*** ERROR ***

+8

*** ERROR ***

+9

*** ERROR ***

 +10      ;X:'APCHSNPG APCHSBRK

BSDX41E.m