BHLOBX3M.m

BHLOBX3M ;cmi/sitka/maw - BHL 3M OBX Supplement  

 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001

 ;

 ;

 ;this routine will supplement the 3M OBX Segment

 ;

 S INA("OBID")=CS_CS_CS_"WT"_CS_"WEIGHT"_CS_BHL("IHST")

 I $$FMDIFF^XLFDT($P(BHL("VDTM"),"."),$P(^DPT(BHL("PAT"),0),"^",3))<30,$$BWT(BHL("PAT")) D

 . S INA("WGT")=$$BWT(BHL("PAT"))

 . S BHLOBX3M=1

 Q

 ;

BWT(P) ;get weight on date of birth

 I '$G(P) Q ""

 NEW M S M=$O(^AUTTMSR("C","02","")) I 'M Q ""

 NEW R,V,D S R=0,(D,V)="" F  S D=$O(^AUPNVMSR("AA",P,M,D)) Q:D'=+D!(V]"")  I D=9999999-$P(^DPT(P,0),"^",3) S R=$O(^AUPNVMSR("AA",P,M,D,0)),V=$P(^AUPNVMSR(R,0),"^",4)

 Q V

 ;

BHLOBX3M  ;cmi/sitka/maw - BHL 3M OBX Supplement  

 +1       ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001

 +2       ;

 +3       ;

 +4       ;this routine will supplement the 3M OBX Segment

 +5       ;

 +6        SET INA("OBID")=CS_CS_CS_"WT"_CS_"WEIGHT"_CS_BHL("IHST")

 +7        IF $$FMDIFF^XLFDT($PIECE(BHL("VDTM"),"."),$PIECE(^DPT(BHL("PAT"),0),"^",3))<30

               IF $$BWT(BHL("PAT"))

                   Begin DoDot:1

 +8                    SET INA("WGT")=$$BWT(BHL("PAT"))

 +9                    SET BHLOBX3M=1

                   End DoDot:1

 +10       QUIT 

 +11      ;

BWT(P)    ;get weight on date of birth

 +1        IF '$GET(P)

               QUIT ""

 +2        NEW M

           SET M=$ORDER(^AUTTMSR("C","02",""))

           IF 'M

               QUIT ""

 +3        NEW R,V,D

           SET R=0

           SET (D,V)=""

           FOR 

               SET D=$ORDER(^AUPNVMSR("AA",P,M,D))

               IF D'=+D!(V]"")

                   QUIT 

               IF D=9999999-$PIECE(^DPT(P,0),"^",3)

                   SET R=$ORDER(^AUPNVMSR("AA",P,M,D,0))

                   SET V=$PIECE(^AUPNVMSR(R,0),"^",4)

 +4        QUIT V

 +5       ;