Routine: BTIUPCC6

BTIUPCC6 ; IHS/ITSC/LJF - IHS PCC OBJECTS ;15-Dec-2015 15:40;DU

 ;;1.0;TEXT INTEGRATION UTILITIES;**1006,1012,1013,1015,1015,1016**;NOV 04, 2004;Build 10

BMI(DFN,TIUCAP,NUM) ;EP -- returns BMI based on last ht and wt

 ; TIUCAP=1 if caption with measurement name is to be returned

 N VTWT,VTHT,RSWT,RSHT,BMI,WTDT,RMAX,X,IDT,HNUM,START,END,WNUM,IDATE,RCNT,DATE,WTDT,RESULT,LINE,APCHMDT

 ;S VTWT=$$VTYPE("WT"),VTHT=$$VTYPE("HT")

 S TIUCAP=$G(TIUCAP)

 S VTWT=$$VTYPE("BMI")

 K ^TMP("BTIUVM",$J),^TMP("BTIUPCC",$J)

 I '$D(NUM) S NUM=1

 S WNUM=NUM+2,HNUM=NUM+10,RMAX=NUM

 S START=DT+1,END=0

 S:START<END X=START,START=END,END=X

 S START=9999999-$S(START#1:START,1:START+.9),END=9999999-END

 S RCNT=0,IDT=START

 ;PCTILE=+G(PCTILE)

 ;D BLDXRF(VTWT,NUM),BLDXRF(VTHT,NUM)

 D BLDXRF(VTWT,NUM)

 F  Q:'IDT!(RCNT=RMAX)  D

 .S VIEN=$C(1)

 .F  S VIEN=$O(^TMP("BTIUVM",$J,VTWT,IDT,VIEN),-1) Q:'VIEN  D  Q:RCNT=RMAX

 ..D GETMSR(VIEN,.BMI,.DATE,.LOC,.ENTERBY)

 ..;IHS/MSC/MGH Save the wt date to use if the ht isn't too old patch 4

 ..;S WTDT=DATE

 ..;S RSHT=$$FNDHT(IDT)

 ..;Q:'RSHT

 ..;S RSWT=RSWT*.45359,RSHT=RSHT*.0254,RSHT=RSHT*RSHT,BMI=+$J(RSWT/RSHT,0,2)

 ..;S:PCTILE BMI=$$BMIPCT(BMI,DFN,DATE)

 ..;Q:'BMI

 ..S RESULT(IDT)=$J(BMI,5,2),RCNT=RCNT+1

 ..;S DATE=WTDT

 .S IDT=$O(^TMP("BTIUVM",$J,VTWT,IDT))

 S CNT=0

 S IDATE="" F  S IDATE=$O(RESULT(IDATE)) Q:IDATE=""!(CNT>NUM)  D

 .S BMI=$G(RESULT(IDATE))

 .S DATE=9999999-IDATE

 .I $$PREG^BTIUPCC6(DFN,"",VIEN)=1 S BMI=BMI_"*"

 .S DATE=$$FMTE^XLFDT(DATE)

 .S CNT=CNT+1

 .S LINE=BMI_" ("_$P(DATE,"@",1)_")"

 .I TIUCAP S Y=$S(CNT=1:"BMI:",1:$$SP(4)) S LINE=Y_" "_LINE

 .S ^TMP("BTIUPCC",$J,CNT,0)=LINE

 I '$D(^TMP("BTIUPCC",$J)) Q "No bmi stored"

 Q "~@^TMP(""BTIUPCC"",$J)"

FNDHT(IDT) ;Find closest height before weight

 N VIEN,RESULT,DOB,SEX,TAGE,X2,X1,SX

 S VIEN=$O(^TMP("BTIUVM",$J,VTHT,IDT,""))

 I 'VIEN D

 .;IHS/MSC/MGH Added in HS logic for lookback days for ht. Patch 4

 .N ID1,ID2,GOOD

 .S DOB=$P(^DPT(DFN,0),U,3),X2=DOB,X1=DT D ^%DTC S TAGE=X

 .S ID1=$O(^TMP("BTIUVM",$J,VTHT,IDT),-1),ID2=$O(^TMP("BTIUVM",$J,VTHT,IDT))

 .I ID1 D

 ..S X1=$P(ID1,".",1),X2=$P(IDT,".",1)

 ..I X1=X2 S ID2=ID1

 .I ID2 D

 ..S X1=9999999-(ID2\1)

 ..S APCHMDT=$$FMDIFF^XLFDT(X1,DOB,1)

 ..S X1=9999999-(IDT\1),X2=9999999-ID2

 ..S X=$$FMDIFF^XLFDT(X1,X2,1)

 ..I ((X>90)&(APCHMDT<1096))!((X>180)&(APCHMDT<4381))!((X>365)&(APCHMDT<6571))!((APCHMDT<6571)&(TAGE>6571)) S ID2=""

 ..S:ID2 VIEN=$O(^TMP("BTIUVM",$J,VTHT,ID2,""))

 D:VIEN GETMSR(VIEN,.RESULT)

 Q $G(RESULT)

GETMSR(VIEN,RESULT,DATE,LOC,ENTERBY) ;

 N X,X12

 S X=$G(^AUPNVMSR(VIEN,0)),X12=$G(^(12))

 S DATE=+X12,ENTERBY=+$P(X12,U,4)

 S RESULT=$$TRIM^XLFSTR($P(X,U,4)),X=+$P(X,U,3)

 S X=$G(^AUPNVSIT(X,0))

 S:'DATE DATE=+X

 S LOC=+$P(X,U,22),DATE(0)=DATE*10000\1/10000

 ; Build temp xref for measurement type

BLDXRF(VTYP,VNUM) ;

 N X,Y,Z,CNT

 S X=0

 K ^TMP("BTIUVM",$J,VTYP)

 S CNT=0

 F  S X=$O(^AUPNVMSR("AA",DFN,VTYP,X)),VIEN=0 Q:'X!(CNT>VNUM)  D

 .F  S VIEN=$O(^AUPNVMSR("AA",DFN,VTYP,X,VIEN)) Q:'VIEN  D

 ..S Z=$G(^AUPNVMSR(VIEN,0)),Y=+$G(^(12)),Y=$S(Y:9999999-Y,1:X)

 ..Q:+Z'=VTYP

 ..Q:$P(Z,U,2)'=DFN

 ..S CNT=CNT+1

 ..S ^TMP("BTIUVM",$J,VTYP,Y,VIEN)=""

VTYPE(X,VMSR) ;

 N FNUM

 S:'$D(VMSR) VMSR=$$VMSR

 S FNUM=$S(VMSR:9999999.07,1:120.51)

 Q +$$FIND1^DIC(FNUM,"","X",$$UP^XLFSTR(X),"B^"_$S(VMSR:"D",1:"APCE^C"))

PREG(DFN,VIEN,VMIEN) ;Determine if BMI is for pregnant patient

 ;Patch 1015 went back to using the ATX API after changes made

 N DOB,X1,X1,TAGE,POV,CODE,TAX,RET,ARRAY

 S RET=0

 S VMIEN=$G(VMIEN),VIEN=$G(VIEN)

 I $$GET1^DIQ(2,DFN,.02,"I")'="F" Q RET    ;Wrong sex

 S TAGE=$$GET1^DIQ(2,DFN,.033)

 I TAGE<10!(TAGE>50) Q RET             ;Wrong age

 ;Find POVs on this visit and check if they are pregnancy POVs

 I VIEN="" D

 .S VIEN=$$GET1^DIQ(9000010.01,VMIEN,.03,"I")

 I '+VIEN Q RET

 S TAX=$O(^ATXAX("B","BQI PREGNANCY DXS",0))

 S POV="" F  S POV=$O(^AUPNVPOV("AD",VIEN,POV)) Q:POV=""!(RET=1)  D

 .S CODE=$$GET1^DIQ(9000010.07,POV,.01,"I")

 .I CODE="" Q

 .S RET=$$ICD^ATXAPI(CODE,TAX,9)

 Q RET

EXAMCMT(DFN,TARGET,CODE) ; Returns the last exam with comments

 NEW EXAM,DATE,RESULT,N,SUB,CNT,MAXLEN,COMM,TXT2,SUBCOUNT,SUBLINE

 K @TARGET

 S MAXLEN=60,CNT=0

 S SUB=$S($L(CODE)=2:"C",1:"B")  ;was code or name sent

 S EXAM=$O(^AUTTEXAM(SUB,CODE,0)) I EXAM="" Q ""

 S DATE=$O(^AUPNVXAM("AA",+$G(DFN),EXAM,0)) I DATE="" Q "None Found"

 S RESULT="Date: "_$$FMTE^XLFDT(9999999-DATE,"D")

 S N=$O(^AUPNVXAM("AA",DFN,EXAM,DATE,0)) I 'N Q RESULT_" Results: No Results"

 S CNT=CNT+1

 S @TARGET@(CNT,0)=RESULT_" Results: "_$$GET1^DIQ(9000010.13,N,.04)

 S COMM=$$GET1^DIQ(9000010.13,N,81101)

 I $L(COMM)>MAXLEN D

 .S TXT2=$$WRAP^TIULS(COMM,MAXLEN)

 .F SUBCOUNT=1:1 S SUBLINE=$P(TXT2,"|",SUBCOUNT) Q:SUBLINE=""  D ADD2(SUBLINE)

 E  D ADD2(COMM)

 Q "~@"_$NA(@TARGET)

ADD2(TXT) ;

 S CNT=CNT+1

 S @TARGET@(CNT,0)=TXT

 ; Returns true if V file is used for vital measurements

VMSR() Q ''$$GET^XPAR("ALL","BEHOVM USE VMSR")

PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data

 Q $E(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)

SP(NUM) ; -- SUBRTN to pad spaces

 Q $$PAD(" ",NUM)

BTIUPCC6  ; IHS/ITSC/LJF - IHS PCC OBJECTS ;15-Dec-2015 15:40;DU

 +1       ;;1.0;TEXT INTEGRATION UTILITIES;**1006,1012,1013,1015,1015,1016**;NOV 04, 2004;Build 10

BMI(DFN,TIUCAP,NUM) ;EP -- returns BMI based on last ht and wt

 +1       ; TIUCAP=1 if caption with measurement name is to be returned

 +2        NEW VTWT,VTHT,RSWT,RSHT,BMI,WTDT,RMAX,X,IDT,HNUM,START,END,WNUM,IDATE,RCNT,DATE,WTDT,RESULT,LINE,APCHMDT

 +3       ;S VTWT=$$VTYPE("WT"),VTHT=$$VTYPE("HT")

 +4        SET TIUCAP=$GET(TIUCAP)

 +5        SET VTWT=$$VTYPE("BMI")

 +6        KILL ^TMP("BTIUVM",$JOB),^TMP("BTIUPCC",$JOB)

 +7        IF '$DATA(NUM)

               SET NUM=1

 +8        SET WNUM=NUM+2

           SET HNUM=NUM+10

           SET RMAX=NUM

 +9        SET START=DT+1

           SET END=0

 +10       IF START<END

               SET X=START

               SET START=END

               SET END=X

 +11       SET START=9999999-$SELECT(START#1:START,1:START+.9)

           SET END=9999999-END

 +12       SET RCNT=0

           SET IDT=START

 +13      ;PCTILE=+G(PCTILE)

 +14      ;D BLDXRF(VTWT,NUM),BLDXRF(VTHT,NUM)

 +15       DO BLDXRF(VTWT,NUM)

 +16       FOR

               IF 'IDT!(RCNT=RMAX)

                   QUIT

               Begin DoDot:1

 +17               SET VIEN=$CHAR(1)

 +18               FOR

                       SET VIEN=$ORDER(^TMP("BTIUVM",$JOB,VTWT,IDT,VIEN),-1)

                       IF 'VIEN

                           QUIT

                       Begin DoDot:2

 +19                       DO GETMSR(VIEN,.BMI,.DATE,.LOC,.ENTERBY)

 +20      ;IHS/MSC/MGH Save the wt date to use if the ht isn't too old patch 4

 +21      ;S WTDT=DATE

 +22      ;S RSHT=$$FNDHT(IDT)

 +23      ;Q:'RSHT

 +24      ;S RSWT=RSWT*.45359,RSHT=RSHT*.0254,RSHT=RSHT*RSHT,BMI=+$J(RSWT/RSHT,0,2)

 +25      ;S:PCTILE BMI=$$BMIPCT(BMI,DFN,DATE)

 +26      ;Q:'BMI

 +27                       SET RESULT(IDT)=$JUSTIFY(BMI,5,2)

                           SET RCNT=RCNT+1

 +28      ;S DATE=WTDT

                       End DoDot:2

                       IF RCNT=RMAX

                           QUIT

 +29               SET IDT=$ORDER(^TMP("BTIUVM",$JOB,VTWT,IDT))

               End DoDot:1

 +30       SET CNT=0

 +31       SET IDATE=""

FOR

               SET IDATE=$ORDER(RESULT(IDATE))

               IF IDATE=""!(CNT>NUM)

                   QUIT

               Begin DoDot:1

 +32               SET BMI=$GET(RESULT(IDATE))

 +33               SET DATE=9999999-IDATE

 +34               IF $$PREG^BTIUPCC6(DFN,"",VIEN)=1

                       SET BMI=BMI_"*"

 +35               SET DATE=$$FMTE^XLFDT(DATE)

 +36               SET CNT=CNT+1

 +37               SET LINE=BMI_" ("_$PIECE(DATE,"@",1)_")"

 +38               IF TIUCAP

                       SET Y=$SELECT(CNT=1:"BMI:",1:$$SP(4))

                       SET LINE=Y_" "_LINE

 +39               SET ^TMP("BTIUPCC",$JOB,CNT,0)=LINE

               End DoDot:1

 +40       IF '$DATA(^TMP("BTIUPCC",$JOB))

               QUIT "No bmi stored"

 +41       QUIT "~@^TMP(""BTIUPCC"",$J)"

FNDHT(IDT) ;Find closest height before weight

 +1        NEW VIEN,RESULT,DOB,SEX,TAGE,X2,X1,SX

 +2        SET VIEN=$ORDER(^TMP("BTIUVM",$JOB,VTHT,IDT,""))

 +3        IF 'VIEN

               Begin DoDot:1

 +4       ;IHS/MSC/MGH Added in HS logic for lookback days for ht. Patch 4

 +5                NEW ID1,ID2,GOOD

 +6                SET DOB=$PIECE(^DPT(DFN,0),U,3)

                   SET X2=DOB

                   SET X1=DT

                   DO ^%DTC

                   SET TAGE=X

 +7                SET ID1=$ORDER(^TMP("BTIUVM",$JOB,VTHT,IDT),-1)

                   SET ID2=$ORDER(^TMP("BTIUVM",$JOB,VTHT,IDT))

 +8                IF ID1

                       Begin DoDot:2

 +9                        SET X1=$PIECE(ID1,".",1)

                           SET X2=$PIECE(IDT,".",1)

 +10                       IF X1=X2

                               SET ID2=ID1

                       End DoDot:2

 +11               IF ID2

                       Begin DoDot:2

 +12                       SET X1=9999999-(ID2\1)

 +13                       SET APCHMDT=$$FMDIFF^XLFDT(X1,DOB,1)

 +14                       SET X1=9999999-(IDT\1)

                           SET X2=9999999-ID2

 +15                       SET X=$$FMDIFF^XLFDT(X1,X2,1)

 +16                       IF ((X>90)&(APCHMDT<1096))!((X>180)&(APCHMDT<4381))!((X>365)&(APCHMDT<6571))!((APCHMDT<6571)&(TAGE>6571))

                               SET ID2=""

 +17                       IF ID2

                               SET VIEN=$ORDER(^TMP("BTIUVM",$JOB,VTHT,ID2,""))

                       End DoDot:2

               End DoDot:1

 +18       IF VIEN

               DO GETMSR(VIEN,.RESULT)

 +19       QUIT $GET(RESULT)

GETMSR(VIEN,RESULT,DATE,LOC,ENTERBY) ;

 +1        NEW X,X12

 +2        SET X=$GET(^AUPNVMSR(VIEN,0))

           SET X12=$GET(^(12))

 +3        SET DATE=+X12

           SET ENTERBY=+$PIECE(X12,U,4)

 +4        SET RESULT=$$TRIM^XLFSTR($PIECE(X,U,4))

           SET X=+$PIECE(X,U,3)

 +5        SET X=$GET(^AUPNVSIT(X,0))

 +6        IF 'DATE

               SET DATE=+X

 +7        SET LOC=+$PIECE(X,U,22)

           SET DATE(0)=DATE*10000\1/10000

 +8        QUIT

 +9       ; Build temp xref for measurement type

BLDXRF(VTYP,VNUM) ;

 +1        NEW X,Y,Z,CNT

 +2        SET X=0

 +3        KILL ^TMP("BTIUVM",$JOB,VTYP)

 +4        SET CNT=0

 +5        FOR

               SET X=$ORDER(^AUPNVMSR("AA",DFN,VTYP,X))

               SET VIEN=0

               IF 'X!(CNT>VNUM)

                   QUIT

               Begin DoDot:1

 +6                FOR

                       SET VIEN=$ORDER(^AUPNVMSR("AA",DFN,VTYP,X,VIEN))

                       IF 'VIEN

                           QUIT

                       Begin DoDot:2

 +7                        SET Z=$GET(^AUPNVMSR(VIEN,0))

                           SET Y=+$GET(^(12))

                           SET Y=$SELECT(Y:9999999-Y,1:X)

 +8                        IF +Z'=VTYP

                               QUIT

 +9                        IF $PIECE(Z,U,2)'=DFN

                               QUIT

 +10                       SET CNT=CNT+1

 +11                       SET ^TMP("BTIUVM",$JOB,VTYP,Y,VIEN)=""

                       End DoDot:2

               End DoDot:1

 +12       QUIT

VTYPE(X,VMSR) ;

 +1        NEW FNUM

 +2        IF '$DATA(VMSR)

               SET VMSR=$$VMSR

 +3        SET FNUM=$SELECT(VMSR:9999999.07,1:120.51)

 +4        QUIT +$$FIND1^DIC(FNUM,"","X",$$UP^XLFSTR(X),"B^"_$SELECT(VMSR:"D",1:"APCE^C"))

PREG(DFN,VIEN,VMIEN) ;Determine if BMI is for pregnant patient

 +1       ;Patch 1015 went back to using the ATX API after changes made

 +2        NEW DOB,X1,X1,TAGE,POV,CODE,TAX,RET,ARRAY

 +3        SET RET=0

 +4        SET VMIEN=$GET(VMIEN)

           SET VIEN=$GET(VIEN)

 +5       ;Wrong sex

           IF $$GET1^DIQ(2,DFN,.02,"I")'="F"

               QUIT RET

 +6        SET TAGE=$$GET1^DIQ(2,DFN,.033)

 +7       ;Wrong age

           IF TAGE<10!(TAGE>50)

               QUIT RET

 +8       ;Find POVs on this visit and check if they are pregnancy POVs

 +9        IF VIEN=""

               Begin DoDot:1

 +10               SET VIEN=$$GET1^DIQ(9000010.01,VMIEN,.03,"I")

               End DoDot:1

 +11       IF '+VIEN

               QUIT RET

 +12       SET TAX=$ORDER(^ATXAX("B","BQI PREGNANCY DXS",0))

 +13       SET POV=""

FOR

               SET POV=$ORDER(^AUPNVPOV("AD",VIEN,POV))

               IF POV=""!(RET=1)

                   QUIT

               Begin DoDot:1

 +14               SET CODE=$$GET1^DIQ(9000010.07,POV,.01,"I")

 +15               IF CODE=""

                       QUIT

 +16               SET RET=$$ICD^ATXAPI(CODE,TAX,9)

               End DoDot:1

 +17       QUIT RET

EXAMCMT(DFN,TARGET,CODE) ; Returns the last exam with comments

 +1        NEW EXAM,DATE,RESULT,N,SUB,CNT,MAXLEN,COMM,TXT2,SUBCOUNT,SUBLINE

 +2        KILL @TARGET

 +3        SET MAXLEN=60

           SET CNT=0

 +4       ;was code or name sent

           SET SUB=$SELECT($LENGTH(CODE)=2:"C",1:"B")

 +5        SET EXAM=$ORDER(^AUTTEXAM(SUB,CODE,0))

           IF EXAM=""

               QUIT ""

 +6        SET DATE=$ORDER(^AUPNVXAM("AA",+$GET(DFN),EXAM,0))

           IF DATE=""

               QUIT "None Found"

 +7        SET RESULT="Date: "_$$FMTE^XLFDT(9999999-DATE,"D")

 +8        SET N=$ORDER(^AUPNVXAM("AA",DFN,EXAM,DATE,0))

           IF 'N

               QUIT RESULT_" Results: No Results"

 +9        SET CNT=CNT+1

 +10       SET @TARGET@(CNT,0)=RESULT_" Results: "_$$GET1^DIQ(9000010.13,N,.04)

 +11       SET COMM=$$GET1^DIQ(9000010.13,N,81101)

 +12       IF $LENGTH(COMM)>MAXLEN

               Begin DoDot:1

 +13               SET TXT2=$$WRAP^TIULS(COMM,MAXLEN)

 +14               FOR SUBCOUNT=1:1

                       SET SUBLINE=$PIECE(TXT2,"|",SUBCOUNT)

                       IF SUBLINE=""

                           QUIT

                       DO ADD2(SUBLINE)

               End DoDot:1

 +15      IF '$TEST

               DO ADD2(COMM)

 +16       QUIT "~@"_$NAME(@TARGET)

 +17      ;

ADD2(TXT) ;

 +1        SET CNT=CNT+1

 +2        SET @TARGET@(CNT,0)=TXT

 +3        QUIT

 +4       ; Returns true if V file is used for vital measurements

VMSR()     QUIT ''$$GET^XPAR("ALL","BEHOVM USE VMSR")

PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data

 +1        QUIT $EXTRACT(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)

 +2       ;

SP(NUM)   ; -- SUBRTN to pad spaces

 +1        QUIT $$PAD(" ",NUM)

BTIUPCC6.m