BHSFAM1 ;IHS/CIA/MGH - Health Summary for Women's health profile ;16-Sep-2013 16:14;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,6,8**;March 17, 2006;Build 22
;===================================================================
;Copy of APCHS8 for use in VA health summary. Incoporates several APIs
;for health summary components
; IHS/TUCSON/LAB - PART 8 OF BHS -- SUMMARY PRODUCTION COMPONENTS ; [ 03/13/01 3:43 PM ]
;;2.0;IHS RPMS/PCC Health Summary;**8,12**;JUN 24, 1997
;====================================================================
OFFHX ; ********** OFFSPRING HISTORY * 9000012 **********
; <SETUP>
N BHSPAT,BHSQ
S BHSPAT=DFN
Q:$P(^DPT(BHSPAT,0),U,2)'="F"
Q:'$D(^AUPNOFFH("AA",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT) D OFFHDR
; <DISPLAY>
S BHSDAT=0 F BHSQ=0:0 S BHSDAT=$O(^AUPNOFFH("AA",BHSPAT,BHSDAT)) Q:'BHSDAT S BHSDFN=0 F BHSQ=0:0 S BHSDFN=$O(^AUPNOFFH("AA",BHSPAT,BHSDAT,BHSDFN)) Q:'BHSDFN D OFFDSP Q:$D(GMTSQIT)
OFFHXX K BHSDAT,BHSDFN,BHSN,BHSP,X,Y
Q
OFFDSP ;
S BHSN=^AUPNOFFH(BHSDFN,0)
D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG OFFHDR
S X=BHSDAT D REGDT4^GMTSU W X,?12,$P(BHSN,U,4),?22,$P(BHSN,U,5),?26,$J(+$P(BHSN,U,6),5,2),?33,$P(BHSN,U,7)
I $P(BHSN,U,8) W ?37,$P(BHSN,U,8),"/",$S($P(BHSN,U,9):$P(BHSN,U,9),1:"-")
I $P(BHSN,U,11) S X=$P(BHSN,U,11) D REGDT4^GMTSU S Y="("_X_$S($P(BHSN,U,12)]"":": "_$P(BHSN,U,12),1:"")_")" W ?44,$E(Y,1,36)
W !
PNC I $O(^AUPNOFFH(BHSDFN,21,0)) W ?10,"PERINATAL COMPLICATION: " S BHSP=0 F S BHSP=$O(^AUPNOFFH(BHSDFN,21,BHSP)) Q:'BHSP S Y=^(BHSP,0) D OUTC Q:$D(GMTSQIT)
Q:$D(GMTSQIT)
NNC I $O(^AUPNOFFH(BHSDFN,31,0)) W ?10,"NEONATAL COMPLICATION: " S BHSP=0 F S BHSP=$O(^AUPNOFFH(BHSDFN,31,BHSP)) Q:'BHSP S Y=^(BHSP,0) D OUTC Q:$D(GMTSQIT)
Q
OFFHDR W "DOB",?12,"NAME",?22,"SEX",?27,"BWT",?33,"EGA",?37,"APGAR",?44,"DEATH",!
Q
OUTC D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG OFFHDR
W ?34,Y,!
Q
;
REPHX ; ********** REPRODUCTIVE HISTORY * 9000017 **********
; <SETUP>
N TOT,GRAV,PARA,LC,SA,TA,OTHER,BHSPAT,LAC,LAC1,LACDATE
S BHSPAT=DFN
Q:$P(^DPT(BHSPAT,0),U,2)'="F"
Q:'$D(^AUPNREP(BHSPAT))
S BHSN=^AUPNREP(BHSPAT,0)
I $D(^DD(9000017,2101)) D NEWREP G REPHXX
; <DISPLAY>
D CKP^GMTSUP Q:$D(GMTSQIT)
S X=$P(BHSN,U,2)
I X]"" D
.S GRAV=$P(X,"P",1),OTHER=$P(X,"P",2)
.S PARA=$P(OTHER,"LC",1),OTHER=$P(OTHER,"LC",2)
.S LC=$P(OTHER,"SA",1),OTHER=$P(OTHER,"SA",2)
.S SA=$P(OTHER,"TA",1),OTHER=$P(OTHER,"TA",2)
.S TA=OTHER
.S TOT=GRAV_" P"_PARA_" LC"_LC_" SA"_SA_" TA"_TA
.W TOT S BHSP=3 D DTOBT W !
S X=$P(BHSN,U,4) S:X="" X="<not recorded>"
I +X D REGDT4^GMTSU W "LMP ",X S BHSP=5 D DTOBT W !
S X=$P(BHSN,U,6)
I X]"" D
.S Y=$P(^DD(9000017,3,0),U,3),X=$P(Y,";",X+1)
.S BHSM=$P(X,":",2)
.D CKP^GMTSUP G:$D(GMTSQIT) REPHXX
.W "CONTRACEPTION: ",BHSM S X=$P(BHSN,U,7) X:+X "S Y=X D REGDT4^GMTSU W "", EFFECTIVE "",X" S BHSP=8 D DTOBT W !
S X=$P(BHSN,U,9) I X]"" D CKP^GMTSUP G:$D(GMTSQIT) REPHXX D EDC
REPHXX K BHSN,BHSM,BHSN11,BHSP,X,Y
Q
;
NEWREP ;new reproductive factors dd
N I
S BHSN11=$G(^AUPNREP(BHSPAT,0))
D CKP^GMTSUP Q:$D(GMTSQIT)
S X=$$RHX^AUPNREP(BHSPAT) I X]"" W !,"Reproductive History: "
F I=1:1:8 D
.W !?2,$P(X,";",I)
.D CKP^GMTSUP Q:$D(GMTSQIT)
S X=$P(BHSN,U,4) I X]"" W !,?2,"LMP: " D REGDT4^GMTSU W X S BHSP=5 D DTOBT W !
;S X=$P(BHSN,U,9) I X]"" D CKP^GMTSUP Q:$D(GMTSQIT) REPHXX D EDC
S LAC=$G(^AUPNREP(BHSPAT,2))
I LAC'="" D
.S LAC1=$$GET1^DIQ(9000017,BHSPAT,2.01)
.S LACDATE=$$GET1^DIQ(9000017,BHSPAT,2.02)
.W ?2,"Lactation Status: "_LAC1_" "_LACDATE,!
D EDC
D LATER
Q
LATER ;
I $O(^AUPNREP(BHSPAT,2101,0)) D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W !!?3,"Contraceptive Method",?40,"Date Started",?55,"Date Ended"
.S BHX=0 F S BHX=$O(^AUPNREP(BHSPAT,2101,BHX)) Q:BHX'=+BHX D
..Q:$D(^AUPNREP(DFN,2101,BHX,1))>0
..S BHC=$P(^AUPNREP(BHSPAT,2101,BHX,0),U,1) I BHC D
...D CKP^GMTSUP Q:$D(GMTSQIT)
...W !?5,$P(^AUTTCM(BHC,0),U)
...S Y=$P(^AUPNREP(BHSPAT,2101,BHX,0),U,2) I Y]"" S Y=$$FIXDT^BHSFAM1(Y) D CKP^GMTSUP W ?40,Y
...S Y=$P(^AUPNREP(BHSPAT,2101,BHX,0),U,3) I Y]"" S Y=$$FIXDT^BHSFAM1(Y) D CKP^GMTSUP W ?55,Y
...S Y=$P(^AUPNREP(BHSPAT,2101,BHX,0),U,4) W:Y]"" !,?10,"(obtained "_$$FIXDT^BHSFAM1(Y)_")" W !
..I $P(^AUPNREP(BHSPAT,2101,BHX,0),U,6)]"" W ?10,$P(^AUPNREP(BHSPAT,2101,BHX,0),U,6),!
..I $P(^AUPNREP(BHSPAT,2101,BHX,0),U,5)]"" W ?5,"Reason Discontinued: "_$P(^AUPNREP(BHSPAT,2101,BHX,0),U,5),!
Q
DTOBT S X=$P(BHSN,U,BHSP) I X]"" D REGDT4^GMTSU W " (obtained ",X,")"
Q
;
EDC ;Get EDC
I $G(APCHAEDD) D ALLEDD Q
NEW APCHDEDD,APCHDEDT,APCHDOBT,APCHBY,F
S APCHDEDD=$$VALI^XBDIQ1(9000017,BHSPAT,1311)
I APCHDEDD]"" D Q
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W "***NOTE: Definitive EDD: ",$$DATE^APCHSMU(APCHDEDD)," (obtained ",$$DATE^APCHSMU($P($P($G(^AUPNREP(BHSPAT,13)),U,12),".")),")" ;
.I APCHDEDD<$$FMADD^XLFDT(DT,-14) W " -- OUTDATED!"
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W !
.I $P($G(^AUPNREP(BHSPAT,15)),U,2)]"" W "Comment: ",$P(^AUPNREP(BHSPAT,15),U,2)
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W !
;no definitive EDD so print latest of the 4 values
;
S APCHDOBT="",APCHBY="",APCHDEDT=""
I $$VAL^XBDIQ1(9000017,BHSPAT,1302)]"" S APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1302),APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1303),APCHBY="LMP"
I $$VAL^XBDIQ1(9000017,BHSPAT,1305)]"",$$VALI^XBDIQ1(9000017,BHSPAT,1306)>APCHDOBT S APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1305),APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1306),APCHBY="ULTRASOUND"
I $$VAL^XBDIQ1(9000017,BHSPAT,1308)]"",$$VALI^XBDIQ1(9000017,BHSPAT,1309)>APCHDOBT S APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1308),APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1309),APCHBY="CLINICAL PARAMETERS"
I $$VAL^XBDIQ1(9000017,BHSPAT,1314)]"",$$VALI^XBDIQ1(9000017,BHSPAT,1315)>APCHDOBT S APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1314),APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1315),APCHBY="UNKNOWN METHOD"
I APCHDEDT]"" D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W "***NOTE: EDD: ",$$DATE^APCHSMU(APCHDEDT)," (obtained ",$$DATE^APCHSMU(APCHDOBT),") BY ",APCHBY
.I APCHDEDT<$$FMADD^XLFDT(DT,-14) W " -- OUTDATED!"
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W !
.S F=$S(APCHBY="LMP":1401,APCHBY="ULTRASOUND":1402,APCHBY="CLINICAL PARAMETERS":1501,1:"1601")
.I $$VAL^XBDIQ1(9000017,BHSPAT,F)]"" W "Comment: ",$$VAL^XBDIQ1(9000017,BHSPAT,F)
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W !
Q
REPEDDHX ;EP - REPRODUCTIVE HISTORY - ALL EDDS
S APCHAEDD=1
D REPHX
K APCHAEDD
Q
;
ALLEDD ;
;print all EDDs with data
;1311, 1314, 1302, 1305, 1308
NEW APCHDEDD,APCHDEDT,APCHDOBT,APCHBY
S APCHDEDD=$$VALI^XBDIQ1(9000017,BHSPAT,1311)
I APCHDEDD]"" D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W "***NOTE: Definitive EDD: ",$$DATE^APCHSMU(APCHDEDD)," (obtained ",$$DATE^APCHSMU($P($P($G(^AUPNREP(BHSPAT,13)),U,12),".")),")" ; BY ",$S(APCHDEDD="L":"LMP",APCHDEDD="U":"ULTRASOUND",APCHDEDD="C":"CLINICAL PARAMETERS",1:"UNKNOWN METHOD")
.I APCHDEDD<$$FMADD^XLFDT(DT,-14) W " -- OUTDATED!"
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W !
.I $P($G(^AUPNREP(BHSPAT,15)),U,2)]"" W "Comment: ",$P(^AUPNREP(BHSPAT,15),U,2)
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W !
;NOW PRINT ALL OTHER EDD VALUES
I $$VAL^XBDIQ1(9000017,BHSPAT,1302)]"" S APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1302),APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1303),APCHBY="LMP" D W
I $$VAL^XBDIQ1(9000017,BHSPAT,1305)]"" S APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1305),APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1306),APCHBY="ULTRASOUND" D W
I $$VAL^XBDIQ1(9000017,BHSPAT,1308)]"" S APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1308),APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1309),APCHBY="CLINICAL PARAMETERS" D W
I $$VAL^XBDIQ1(9000017,BHSPAT,1314)]"" S APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1314),APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1315),APCHBY="UNKNOWN METHOD" D W
Q
W ;
I APCHDEDT]"" D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W "***NOTE: EDD: ",$$DATE^APCHSMU(APCHDEDT)," (obtained ",$$DATE^APCHSMU(APCHDOBT),") BY ",APCHBY
.I APCHDEDT<$$FMADD^XLFDT(DT,-14) W " -- OUTDATED!"
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W !
.S F=$S(APCHBY="LMP":1401,APCHBY="ULTRASOUND":1402,APCHBY="CLINICAL PARAMETERS":1501,1:"1601")
.I $$VAL^XBDIQ1(9000017,BHSPAT,F)]"" W "Comment: ",$$VAL^XBDIQ1(9000017,BHSPAT,F)
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W !
.Q
Q
;
TRTMT ; ********** TREATMENTS * 9000010.15 **********
; <SETUP>
N BHSPAT,BHSQ
S BHSPAT=DFN
Q:'$D(^AUPNVTRT("AA",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVTRT("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDTT=X S BHSDTU=0 D ONEDATE Q:$D(GMTSQIT) S GMTSNDM=GMTSNDM-BHSDTU Q:GMTSNDM=0
; <CLEANUP>
TRTMTX K BHSVDF,BHSIVD,BHSDTU,BHSDTT,BHSDFN,BHSFO,BHSFAC,BHSNT,BHST,BHSLVL,BHSLVT,BHSN
K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE
Q
ONEDATE S BHSDFN="" F BHSQ=0:0 S BHSDFN=$O(^AUPNVTRT("AA",BHSPAT,BHSIVD,BHSDFN)) Q:BHSDFN="" D TRTCHK Q:$D(GMTSQIT)
Q
TRTCHK S BHSN=^AUPNVTRT(BHSDFN,0)
Q:'$P(^AUTTTRT($P(BHSN,U,1),0),U,3)
S BHSVDF=$P(BHSN,U,3) D GETSITEV^BHSUTL Q:"ADTC"'[BHSVSC
D CKP^GMTSUP Q:$D(GMTSQIT) S:GMTSNPG BHSDTU=0
I 'BHSDTU W BHSDTT S BHSFO=""
I BHSNSH=BHSFO S BHSFAC=""
E S (BHSFAC,BHSFO)=BHSNSH
S BHSDTU=1
S BHST=$P(BHSN,U,1),BHST=$P(^AUTTTRT(BHST,0),U,1)
S BHSNT=+$P(BHSN,U,4)
S BHSLVL=$P(BHSN,U,6),BHSLVT=""
I BHSLVL]"" S BHSLVT=$P(^DD(9000010.15,.06,0),U,3),BHSLVT=$P($P(BHSLVT,BHSLVL_":",2),";",1),BHSLVT=" - "_$P(BHSLVT,",",1)_" UNDERSTANDING"
D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG BHSDTT W ?10,$E(BHSFAC,1,10),?21,BHST," (",BHSNT,")",BHSLVT,!
Q
;
TXC ;EP - called from component
; <SETUP>
N BHSPAT
S BHSPAT=DFN
Q:'$D(^AUPNVTXC("AA",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
S BHST="" F BHSQ=0:0 S BHST=$O(^AUPNVTXC("AA",BHSPAT,BHST)) Q:BHST="" S BHSTX=$$EXTSET^XBFUNC(9000010.39,.01,BHST),BHSTL=$L(BHSTX) D CKP^GMTSUP Q:$D(GMTSQIT) D TXDSP6
; <CLEANUP>
TXCX K BHST,BHSTX,BHSTL,BHSIVD,BHSDFN,BHSDI,BHSVDF,BHSDAT,BHSCNT,BHS,X,Y
K BHSNFL,BHSNSH,BHSNAB,BHSPI,BHSVSC,BHSITE,BHC,BHX,REPHXX
Q
TXDSP6 ;get contract type
S BHSCNT=0
W ! D CKP^GMTSUP Q:$D(GMTSQIT) W BHSTX S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVTXC("AA",BHSPAT,BHST,BHSIVD)) S BHSCNT=BHSCNT+1 Q:BHSIVD=""!(BHSCNT>6) D TXDSP13
Q
TXDSP13 ;
S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
S BHSDFN=0 F BHSQ=0:0 S BHSDFN=$O(^AUPNVTXC("AA",BHSPAT,BHST,BHSIVD,BHSDFN)) Q:'BHSDFN!(BHSCNT>6) D TXDSP23
Q
TXDSP23 ;
S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
S BHSVDF=$P(^AUPNVTXC(BHSDFN,0),U,3) ;D GETSITEV^BHSUTL S BHSITE=BHSNSH
S BHSDI=$$VAL^XBDIQ1(9000010.39,BHSDFN,.04)
S BHSPI=$$VAL^XBDIQ1(9000010.39,BHSDFN,.05)
D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG BHSTX W ?20,BHSDI,?40,BHSPI,!
Q
BIRTHM ; ********** BIRTH MEASUREMENTS 9000024 AND V INFANT FEEDING 9000010.44 **********
; <SETUP>
N BHSPAT,X,V
S BHSPAT=DFN
I '$D(^AUPNBMSR("B",BHSPAT)),'$O(^AUPNVIF("AC",BHSPAT,0)) Q
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
S APCHX=$G(^AUPNBMSR(BHSPAT,0))
W "BIRTH WEIGHT (kg)",?30,$P(APCHX,U,18)
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,"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" W ?30,X
D CKP^GMTSUP Q:$D(GMTSQIT)
S X=$P(APCHX,U,12) W !,"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" W ?30,X
D CKP^GMTSUP Q:$D(GMTSQIT)
S X=$P(APCHX,U,14) W !,"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" W ?30,X
D CKP^GMTSUP Q:$D(GMTSQIT)
S X=$P(APCHX,U,16) W !,"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" W ?30,X
Q:'$O(^AUPNVIF("AC",BHSPAT,0))
K APCHT S APCHX=0 F S APCHX=$O(^AUPNVIF("AC",BHSPAT,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(BHSPAT,V,"E")_U_$$VAL^XBDIQ1(9000010.44,APCHX,.01)
.Q
;write out data
D CKP^GMTSUP Q:$D(GMTSQIT)
W !!,"VISIT DATE",?20,"AGE",?32,"FEEDING CHOICE",!
S APCHD=0 F S APCHD=$O(APCHT(APCHD)) Q:APCHD'=+APCHD!($D(GMTSQIT)) S APCHX=0 F S APCHX=$O(APCHT(APCHD,APCHX)) Q:APCHX'=+APCHX!($D(GMTSQIT)) D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W $$DATE^BHSMU(APCHD),?20,$P(APCHT(APCHD,APCHX),U),?32,$P(APCHT(APCHD,APCHX),U,2),!
.;ADDITIONAL FEEDING CHOICES
.Q:'$O(^AUPNVIF(APCHX,13,0))
.W ?10,"ADDITIONAL FEEDING CHOICES:"
.S APCHAX=0 F S APCHAX=$O(^AUPNVIF(APCHX,13,APCHAX)) Q:APCHAX'=+APCHAX D
..D CKP^GMTSUP Q:$D(GMTSQIT)
..S APCHIENS=APCHAX_","_APCHX
..W ?40,$$GET1^DIQ(9000010.4413,APCHIENS,.01),!
..I $P($G(^AUPNVIF(APCHX,13,APCHAX,0)),U,2)]"" W ?10,"COMMENT: ",$$GET1^DIQ(9000010.4413,APCHIENS,.02),!
.Q
BRTHX K BHSDAT,BHSDFN,BHSN,BHSP,X,Y,APCHX,APCHT,APCHD,APCHIENS,APCHAX
Q
FIXDT(VAL) ;Change format for imprecise dates
N RET
S RET=VAL
I +$P(VAL,"/",1)=0!(+$P(VAL,"/",2)=0) S RET=$$FMTE^XLFDT(VAL)
Q RET
BHSFAM1 ;IHS/CIA/MGH - Health Summary for Women's health profile ;16-Sep-2013 16:14;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,6,8**;March 17, 2006;Build 22
+2 ;===================================================================
+3 ;Copy of APCHS8 for use in VA health summary. Incoporates several APIs
+4 ;for health summary components
+5 ; IHS/TUCSON/LAB - PART 8 OF BHS -- SUMMARY PRODUCTION COMPONENTS ; [ 03/13/01 3:43 PM ]
+6 ;;2.0;IHS RPMS/PCC Health Summary;**8,12**;JUN 24, 1997
+7 ;====================================================================
OFFHX ; ********** OFFSPRING HISTORY * 9000012 **********
+1 ; <SETUP>
+2 NEW BHSPAT,BHSQ
+3 SET BHSPAT=DFN
+4 IF $PIECE(^DPT(BHSPAT,0),U,2)'="F"
QUIT
+5 IF '$DATA(^AUPNOFFH("AA",BHSPAT))
QUIT
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
DO OFFHDR
+7 ; <DISPLAY>
+8 SET BHSDAT=0
FOR BHSQ=0:0
SET BHSDAT=$ORDER(^AUPNOFFH("AA",BHSPAT,BHSDAT))
IF 'BHSDAT
QUIT
SET BHSDFN=0
FOR BHSQ=0:0
SET BHSDFN=$ORDER(^AUPNOFFH("AA",BHSPAT,BHSDAT,BHSDFN))
IF 'BHSDFN
QUIT
DO OFFDSP
IF $DATA(GMTSQIT)
QUIT
OFFHXX KILL BHSDAT,BHSDFN,BHSN,BHSP,X,Y
+1 QUIT
OFFDSP ;
+1 SET BHSN=^AUPNOFFH(BHSDFN,0)
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
DO OFFHDR
+3 SET X=BHSDAT
DO REGDT4^GMTSU
WRITE X,?12,$PIECE(BHSN,U,4),?22,$PIECE(BHSN,U,5),?26,$JUSTIFY(+$PIECE(BHSN,U,6),5,2),?33,$PIECE(BHSN,U,7)
+4 IF $PIECE(BHSN,U,8)
WRITE ?37,$PIECE(BHSN,U,8),"/",$SELECT($PIECE(BHSN,U,9):$PIECE(BHSN,U,9),1:"-")
+5 IF $PIECE(BHSN,U,11)
SET X=$PIECE(BHSN,U,11)
DO REGDT4^GMTSU
SET Y="("_X_$SELECT($PIECE(BHSN,U,12)]"":": "_$PIECE(BHSN,U,12),1:"")_")"
WRITE ?44,$EXTRACT(Y,1,36)
+6 WRITE !
PNC IF $ORDER(^AUPNOFFH(BHSDFN,21,0))
WRITE ?10,"PERINATAL COMPLICATION: "
SET BHSP=0
FOR
SET BHSP=$ORDER(^AUPNOFFH(BHSDFN,21,BHSP))
IF 'BHSP
QUIT
SET Y=^(BHSP,0)
DO OUTC
IF $DATA(GMTSQIT)
QUIT
+1 IF $DATA(GMTSQIT)
QUIT
NNC IF $ORDER(^AUPNOFFH(BHSDFN,31,0))
WRITE ?10,"NEONATAL COMPLICATION: "
SET BHSP=0
FOR
SET BHSP=$ORDER(^AUPNOFFH(BHSDFN,31,BHSP))
IF 'BHSP
QUIT
SET Y=^(BHSP,0)
DO OUTC
IF $DATA(GMTSQIT)
QUIT
+1 QUIT
OFFHDR WRITE "DOB",?12,"NAME",?22,"SEX",?27,"BWT",?33,"EGA",?37,"APGAR",?44,"DEATH",!
+1 QUIT
OUTC DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
DO OFFHDR
+1 WRITE ?34,Y,!
+2 QUIT
+3 ;
REPHX ; ********** REPRODUCTIVE HISTORY * 9000017 **********
+1 ; <SETUP>
+2 NEW TOT,GRAV,PARA,LC,SA,TA,OTHER,BHSPAT,LAC,LAC1,LACDATE
+3 SET BHSPAT=DFN
+4 IF $PIECE(^DPT(BHSPAT,0),U,2)'="F"
QUIT
+5 IF '$DATA(^AUPNREP(BHSPAT))
QUIT
+6 SET BHSN=^AUPNREP(BHSPAT,0)
+7 IF $DATA(^DD(9000017,2101))
DO NEWREP
GOTO REPHXX
+8 ; <DISPLAY>
+9 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+10 SET X=$PIECE(BHSN,U,2)
+11 IF X]""
Begin DoDot:1
+12 SET GRAV=$PIECE(X,"P",1)
SET OTHER=$PIECE(X,"P",2)
+13 SET PARA=$PIECE(OTHER,"LC",1)
SET OTHER=$PIECE(OTHER,"LC",2)
+14 SET LC=$PIECE(OTHER,"SA",1)
SET OTHER=$PIECE(OTHER,"SA",2)
+15 SET SA=$PIECE(OTHER,"TA",1)
SET OTHER=$PIECE(OTHER,"TA",2)
+16 SET TA=OTHER
+17 SET TOT=GRAV_" P"_PARA_" LC"_LC_" SA"_SA_" TA"_TA
+18 WRITE TOT
SET BHSP=3
DO DTOBT
WRITE !
End DoDot:1
+19 SET X=$PIECE(BHSN,U,4)
IF X=""
SET X="<not recorded>"
+20 IF +X
DO REGDT4^GMTSU
WRITE "LMP ",X
SET BHSP=5
DO DTOBT
WRITE !
+21 SET X=$PIECE(BHSN,U,6)
+22 IF X]""
Begin DoDot:1
+23 SET Y=$PIECE(^DD(9000017,3,0),U,3)
SET X=$PIECE(Y,";",X+1)
+24 SET BHSM=$PIECE(X,":",2)
+25 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
GOTO REPHXX
+26 WRITE "CONTRACEPTION: ",BHSM
SET X=$PIECE(BHSN,U,7)
IF +X
XECUTE "S Y=X D REGDT4^GMTSU W "", EFFECTIVE "",X"
SET BHSP=8
DO DTOBT
WRITE !
End DoDot:1
+27 SET X=$PIECE(BHSN,U,9)
IF X]""
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
GOTO REPHXX
DO EDC
REPHXX KILL BHSN,BHSM,BHSN11,BHSP,X,Y
+1 QUIT
+2 ;
NEWREP ;new reproductive factors dd
+1 NEW I
+2 SET BHSN11=$GET(^AUPNREP(BHSPAT,0))
+3 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+4 SET X=$$RHX^AUPNREP(BHSPAT)
IF X]""
WRITE !,"Reproductive History: "
+5 FOR I=1:1:8
Begin DoDot:1
+6 WRITE !?2,$PIECE(X,";",I)
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
End DoDot:1
+8 SET X=$PIECE(BHSN,U,4)
IF X]""
WRITE !,?2,"LMP: "
DO REGDT4^GMTSU
WRITE X
SET BHSP=5
DO DTOBT
WRITE !
+9 ;S X=$P(BHSN,U,9) I X]"" D CKP^GMTSUP Q:$D(GMTSQIT) REPHXX D EDC
+10 SET LAC=$GET(^AUPNREP(BHSPAT,2))
+11 IF LAC'=""
Begin DoDot:1
+12 SET LAC1=$$GET1^DIQ(9000017,BHSPAT,2.01)
+13 SET LACDATE=$$GET1^DIQ(9000017,BHSPAT,2.02)
+14 WRITE ?2,"Lactation Status: "_LAC1_" "_LACDATE,!
End DoDot:1
+15 DO EDC
+16 DO LATER
+17 QUIT
LATER ;
+1 IF $ORDER(^AUPNREP(BHSPAT,2101,0))
Begin DoDot:1
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+3 WRITE !!?3,"Contraceptive Method",?40,"Date Started",?55,"Date Ended"
+4 SET BHX=0
FOR
SET BHX=$ORDER(^AUPNREP(BHSPAT,2101,BHX))
IF BHX'=+BHX
QUIT
Begin DoDot:2
+5 IF $DATA(^AUPNREP(DFN,2101,BHX,1))>0
QUIT
+6 SET BHC=$PIECE(^AUPNREP(BHSPAT,2101,BHX,0),U,1)
IF BHC
Begin DoDot:3
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+8 WRITE !?5,$PIECE(^AUTTCM(BHC,0),U)
+9 SET Y=$PIECE(^AUPNREP(BHSPAT,2101,BHX,0),U,2)
IF Y]""
SET Y=$$FIXDT^BHSFAM1(Y)
DO CKP^GMTSUP
WRITE ?40,Y
+10 SET Y=$PIECE(^AUPNREP(BHSPAT,2101,BHX,0),U,3)
IF Y]""
SET Y=$$FIXDT^BHSFAM1(Y)
DO CKP^GMTSUP
WRITE ?55,Y
+11 SET Y=$PIECE(^AUPNREP(BHSPAT,2101,BHX,0),U,4)
IF Y]""
WRITE !,?10,"(obtained "_$$FIXDT^BHSFAM1(Y)_")"
WRITE !
End DoDot:3
+12 IF $PIECE(^AUPNREP(BHSPAT,2101,BHX,0),U,6)]""
WRITE ?10,$PIECE(^AUPNREP(BHSPAT,2101,BHX,0),U,6),!
+13 IF $PIECE(^AUPNREP(BHSPAT,2101,BHX,0),U,5)]""
WRITE ?5,"Reason Discontinued: "_$PIECE(^AUPNREP(BHSPAT,2101,BHX,0),U,5),!
End DoDot:2
End DoDot:1
+14 QUIT
DTOBT SET X=$PIECE(BHSN,U,BHSP)
IF X]""
DO REGDT4^GMTSU
WRITE " (obtained ",X,")"
+1 QUIT
+2 ;
EDC ;Get EDC
+1 IF $GET(APCHAEDD)
DO ALLEDD
QUIT
+2 NEW APCHDEDD,APCHDEDT,APCHDOBT,APCHBY,F
+3 SET APCHDEDD=$$VALI^XBDIQ1(9000017,BHSPAT,1311)
+4 IF APCHDEDD]""
Begin DoDot:1
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 ;
WRITE "***NOTE: Definitive EDD: ",$$DATE^APCHSMU(APCHDEDD)," (obtained ",$$DATE^APCHSMU($PIECE($PIECE($GET(^AUPNREP(BHSPAT,13)),U,12),".")),")"
+7 IF APCHDEDD<$$FMADD^XLFDT(DT,-14)
WRITE " -- OUTDATED!"
+8 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+9 WRITE !
+10 IF $PIECE($GET(^AUPNREP(BHSPAT,15)),U,2)]""
WRITE "Comment: ",$PIECE(^AUPNREP(BHSPAT,15),U,2)
+11 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+12 WRITE !
End DoDot:1
QUIT
+13 ;no definitive EDD so print latest of the 4 values
+14 ;
+15 SET APCHDOBT=""
SET APCHBY=""
SET APCHDEDT=""
+16 IF $$VAL^XBDIQ1(9000017,BHSPAT,1302)]""
SET APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1302)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1303)
SET APCHBY="LMP"
+17 IF $$VAL^XBDIQ1(9000017,BHSPAT,1305)]""
IF $$VALI^XBDIQ1(9000017,BHSPAT,1306)>APCHDOBT
SET APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1305)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1306)
SET APCHBY="ULTRASOUND"
+18 IF $$VAL^XBDIQ1(9000017,BHSPAT,1308)]""
IF $$VALI^XBDIQ1(9000017,BHSPAT,1309)>APCHDOBT
SET APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1308)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1309)
SET APCHBY="CLINICAL PARAMETERS"
+19 IF $$VAL^XBDIQ1(9000017,BHSPAT,1314)]""
IF $$VALI^XBDIQ1(9000017,BHSPAT,1315)>APCHDOBT
SET APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1314)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1315)
SET APCHBY="UNKNOWN METHOD"
+20 IF APCHDEDT]""
Begin DoDot:1
+21 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+22 WRITE "***NOTE: EDD: ",$$DATE^APCHSMU(APCHDEDT)," (obtained ",$$DATE^APCHSMU(APCHDOBT),") BY ",APCHBY
+23 IF APCHDEDT<$$FMADD^XLFDT(DT,-14)
WRITE " -- OUTDATED!"
+24 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+25 WRITE !
+26 SET F=$SELECT(APCHBY="LMP":1401,APCHBY="ULTRASOUND":1402,APCHBY="CLINICAL PARAMETERS":1501,1:"1601")
+27 IF $$VAL^XBDIQ1(9000017,BHSPAT,F)]""
WRITE "Comment: ",$$VAL^XBDIQ1(9000017,BHSPAT,F)
+28 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+29 WRITE !
End DoDot:1
+30 QUIT
REPEDDHX ;EP - REPRODUCTIVE HISTORY - ALL EDDS
+1 SET APCHAEDD=1
+2 DO REPHX
+3 KILL APCHAEDD
+4 QUIT
+5 ;
ALLEDD ;
+1 ;print all EDDs with data
+2 ;1311, 1314, 1302, 1305, 1308
+3 NEW APCHDEDD,APCHDEDT,APCHDOBT,APCHBY
+4 SET APCHDEDD=$$VALI^XBDIQ1(9000017,BHSPAT,1311)
+5 IF APCHDEDD]""
Begin DoDot:1
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+7 ; BY ",$S(APCHDEDD="L":"LMP",APCHDEDD="U":"ULTRASOUND",APCHDEDD="C":"CLINICAL PARAMETERS",1:"UNKNOWN METHOD")
WRITE "***NOTE: Definitive EDD: ",$$DATE^APCHSMU(APCHDEDD)," (obtained ",$$DATE^APCHSMU($PIECE($PIECE($GET(^AUPNREP(BHSPAT,13)),U,12),".")),")"
+8 IF APCHDEDD<$$FMADD^XLFDT(DT,-14)
WRITE " -- OUTDATED!"
+9 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+10 WRITE !
+11 IF $PIECE($GET(^AUPNREP(BHSPAT,15)),U,2)]""
WRITE "Comment: ",$PIECE(^AUPNREP(BHSPAT,15),U,2)
+12 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+13 WRITE !
End DoDot:1
+14 ;NOW PRINT ALL OTHER EDD VALUES
+15 IF $$VAL^XBDIQ1(9000017,BHSPAT,1302)]""
SET APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1302)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1303)
SET APCHBY="LMP"
DO W
+16 IF $$VAL^XBDIQ1(9000017,BHSPAT,1305)]""
SET APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1305)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1306)
SET APCHBY="ULTRASOUND"
DO W
+17 IF $$VAL^XBDIQ1(9000017,BHSPAT,1308)]""
SET APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1308)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1309)
SET APCHBY="CLINICAL PARAMETERS"
DO W
+18 IF $$VAL^XBDIQ1(9000017,BHSPAT,1314)]""
SET APCHDEDT=$$VALI^XBDIQ1(9000017,BHSPAT,1314)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,BHSPAT,1315)
SET APCHBY="UNKNOWN METHOD"
DO W
+19 QUIT
W ;
+1 IF APCHDEDT]""
Begin DoDot:1
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+3 WRITE "***NOTE: EDD: ",$$DATE^APCHSMU(APCHDEDT)," (obtained ",$$DATE^APCHSMU(APCHDOBT),") BY ",APCHBY
+4 IF APCHDEDT<$$FMADD^XLFDT(DT,-14)
WRITE " -- OUTDATED!"
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 WRITE !
+7 SET F=$SELECT(APCHBY="LMP":1401,APCHBY="ULTRASOUND":1402,APCHBY="CLINICAL PARAMETERS":1501,1:"1601")
+8 IF $$VAL^XBDIQ1(9000017,BHSPAT,F)]""
WRITE "Comment: ",$$VAL^XBDIQ1(9000017,BHSPAT,F)
+9 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+10 WRITE !
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
TRTMT ; ********** TREATMENTS * 9000010.15 **********
+1 ; <SETUP>
+2 NEW BHSPAT,BHSQ
+3 SET BHSPAT=DFN
+4 IF '$DATA(^AUPNVTRT("AA",BHSPAT))
QUIT
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 ; <DISPLAY>
+7 SET BHSIVD=""
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^AUPNVTRT("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
SET X=-BHSIVD\1+9999999
DO REGDT4^GMTSU
SET BHSDTT=X
SET BHSDTU=0
DO ONEDATE
IF $DATA(GMTSQIT)
QUIT
SET GMTSNDM=GMTSNDM-BHSDTU
IF GMTSNDM=0
QUIT
+8 ; <CLEANUP>
TRTMTX KILL BHSVDF,BHSIVD,BHSDTU,BHSDTT,BHSDFN,BHSFO,BHSFAC,BHSNT,BHST,BHSLVL,BHSLVT,BHSN
+1 KILL BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE
+2 QUIT
ONEDATE SET BHSDFN=""
FOR BHSQ=0:0
SET BHSDFN=$ORDER(^AUPNVTRT("AA",BHSPAT,BHSIVD,BHSDFN))
IF BHSDFN=""
QUIT
DO TRTCHK
IF $DATA(GMTSQIT)
QUIT
+1 QUIT
TRTCHK SET BHSN=^AUPNVTRT(BHSDFN,0)
+1 IF '$PIECE(^AUTTTRT($PIECE(BHSN,U,1),0),U,3)
QUIT
+2 SET BHSVDF=$PIECE(BHSN,U,3)
DO GETSITEV^BHSUTL
IF "ADTC"'[BHSVSC
QUIT
+3 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
SET BHSDTU=0
+4 IF 'BHSDTU
WRITE BHSDTT
SET BHSFO=""
+5 IF BHSNSH=BHSFO
SET BHSFAC=""
+6 IF '$TEST
SET (BHSFAC,BHSFO)=BHSNSH
+7 SET BHSDTU=1
+8 SET BHST=$PIECE(BHSN,U,1)
SET BHST=$PIECE(^AUTTTRT(BHST,0),U,1)
+9 SET BHSNT=+$PIECE(BHSN,U,4)
+10 SET BHSLVL=$PIECE(BHSN,U,6)
SET BHSLVT=""
+11 IF BHSLVL]""
SET BHSLVT=$PIECE(^DD(9000010.15,.06,0),U,3)
SET BHSLVT=$PIECE($PIECE(BHSLVT,BHSLVL_":",2),";",1)
SET BHSLVT=" - "_$PIECE(BHSLVT,",",1)_" UNDERSTANDING"
+12 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE BHSDTT
WRITE ?10,$EXTRACT(BHSFAC,1,10),?21,BHST," (",BHSNT,")",BHSLVT,!
+13 QUIT
+14 ;
TXC ;EP - called from component
+1 ; <SETUP>
+2 NEW BHSPAT
+3 SET BHSPAT=DFN
+4 IF '$DATA(^AUPNVTXC("AA",BHSPAT))
QUIT
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 ; <DISPLAY>
+7 SET BHST=""
FOR BHSQ=0:0
SET BHST=$ORDER(^AUPNVTXC("AA",BHSPAT,BHST))
IF BHST=""
QUIT
SET BHSTX=$$EXTSET^XBFUNC(9000010.39,.01,BHST)
SET BHSTL=$LENGTH(BHSTX)
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
DO TXDSP6
+8 ; <CLEANUP>
TXCX KILL BHST,BHSTX,BHSTL,BHSIVD,BHSDFN,BHSDI,BHSVDF,BHSDAT,BHSCNT,BHS,X,Y
+1 KILL BHSNFL,BHSNSH,BHSNAB,BHSPI,BHSVSC,BHSITE,BHC,BHX,REPHXX
+2 QUIT
TXDSP6 ;get contract type
+1 SET BHSCNT=0
+2 WRITE !
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE BHSTX
SET BHSIVD=""
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^AUPNVTXC("AA",BHSPAT,BHST,BHSIVD))
SET BHSCNT=BHSCNT+1
IF BHSIVD=""!(BHSCNT>6)
QUIT
DO TXDSP13
+3 QUIT
TXDSP13 ;
+1 SET X=-BHSIVD\1+9999999
DO REGDT4^GMTSU
SET BHSDAT=X
+2 SET BHSDFN=0
FOR BHSQ=0:0
SET BHSDFN=$ORDER(^AUPNVTXC("AA",BHSPAT,BHST,BHSIVD,BHSDFN))
IF 'BHSDFN!(BHSCNT>6)
QUIT
DO TXDSP23
+3 QUIT
TXDSP23 ;
+1 SET X=-BHSIVD\1+9999999
DO REGDT4^GMTSU
SET BHSDAT=X
+2 ;D GETSITEV^BHSUTL S BHSITE=BHSNSH
SET BHSVDF=$PIECE(^AUPNVTXC(BHSDFN,0),U,3)
+3 SET BHSDI=$$VAL^XBDIQ1(9000010.39,BHSDFN,.04)
+4 SET BHSPI=$$VAL^XBDIQ1(9000010.39,BHSDFN,.05)
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE BHSTX
WRITE ?20,BHSDI,?40,BHSPI,!
+6 QUIT
BIRTHM ; ********** BIRTH MEASUREMENTS 9000024 AND V INFANT FEEDING 9000010.44 **********
+1 ; <SETUP>
+2 NEW BHSPAT,X,V
+3 SET BHSPAT=DFN
+4 IF '$DATA(^AUPNBMSR("B",BHSPAT))
IF '$ORDER(^AUPNVIF("AC",BHSPAT,0))
QUIT
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 ; <DISPLAY>
+7 SET APCHX=$GET(^AUPNBMSR(BHSPAT,0))
+8 WRITE "BIRTH WEIGHT (kg)",?30,$PIECE(APCHX,U,18)
+9 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+10 WRITE !,"BIRTH ORDER"
SET X=$PIECE(APCHX,U,11)
IF X["W"
SET X=+X_" weeks"
IF X["D"
SET X=+X_" days"
IF X["M"
SET X=+X_" months"
IF X["Y"
SET X=+X_" years"
WRITE ?30,X
+11 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+12 SET X=$PIECE(APCHX,U,12)
WRITE !,"FORMULA STARTED (age)"
IF X["W"
SET X=+X_" weeks"
IF X["D"
SET X=+X_" days"
IF X["M"
SET X=+X_" months"
IF X["Y"
SET X=+X_" years"
WRITE ?30,X
+13 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+14 SET X=$PIECE(APCHX,U,14)
WRITE !,"BREAST STOPPED (age)"
IF X["W"
SET X=+X_" weeks"
IF X["D"
SET X=+X_" days"
IF X["M"
SET X=+X_" months"
IF X["Y"
SET X=+X_" years"
WRITE ?30,X
+15 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+16 SET X=$PIECE(APCHX,U,16)
WRITE !,"SOLIDS BEGUN (age)"
IF X["W"
SET X=+X_" weeks"
IF X["D"
SET X=+X_" days"
IF X["M"
SET X=+X_" months"
IF X["Y"
SET X=+X_" years"
WRITE ?30,X
+17 IF '$ORDER(^AUPNVIF("AC",BHSPAT,0))
QUIT
+18 KILL APCHT
SET APCHX=0
FOR
SET APCHX=$ORDER(^AUPNVIF("AC",BHSPAT,APCHX))
IF APCHX'=+APCHX
QUIT
Begin DoDot:1
+19 SET V=$PIECE(^AUPNVIF(APCHX,0),U,3)
+20 IF 'V
QUIT
+21 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+22 IF V=""
QUIT
+23 SET APCHT(V,APCHX)=$$AGE^AUPNPAT(BHSPAT,V,"E")_U_$$VAL^XBDIQ1(9000010.44,APCHX,.01)
+24 QUIT
End DoDot:1
+25 ;write out data
+26 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+27 WRITE !!,"VISIT DATE",?20,"AGE",?32,"FEEDING CHOICE",!
+28 SET APCHD=0
FOR
SET APCHD=$ORDER(APCHT(APCHD))
IF APCHD'=+APCHD!($DATA(GMTSQIT))
QUIT
SET APCHX=0
FOR
SET APCHX=$ORDER(APCHT(APCHD,APCHX))
IF APCHX'=+APCHX!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+29 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+30 WRITE $$DATE^BHSMU(APCHD),?20,$PIECE(APCHT(APCHD,APCHX),U),?32,$PIECE(APCHT(APCHD,APCHX),U,2),!
+31 ;ADDITIONAL FEEDING CHOICES
+32 IF '$ORDER(^AUPNVIF(APCHX,13,0))
QUIT
+33 WRITE ?10,"ADDITIONAL FEEDING CHOICES:"
+34 SET APCHAX=0
FOR
SET APCHAX=$ORDER(^AUPNVIF(APCHX,13,APCHAX))
IF APCHAX'=+APCHAX
QUIT
Begin DoDot:2
+35 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+36 SET APCHIENS=APCHAX_","_APCHX
+37 WRITE ?40,$$GET1^DIQ(9000010.4413,APCHIENS,.01),!
+38 IF $PIECE($GET(^AUPNVIF(APCHX,13,APCHAX,0)),U,2)]""
WRITE ?10,"COMMENT: ",$$GET1^DIQ(9000010.4413,APCHIENS,.02),!
End DoDot:2
+39 QUIT
End DoDot:1
BRTHX KILL BHSDAT,BHSDFN,BHSN,BHSP,X,Y,APCHX,APCHT,APCHD,APCHIENS,APCHAX
+1 QUIT
FIXDT(VAL) ;Change format for imprecise dates
+1 NEW RET
+2 SET RET=VAL
+3 IF +$PIECE(VAL,"/",1)=0!(+$PIECE(VAL,"/",2)=0)
SET RET=$$FMTE^XLFDT(VAL)
+4 QUIT RET
