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

BHSFAM1.m

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