BTIUPV2.m

BTIUPV2 ; IHS/MSC/MGH - Problem Objects ;16-Aug-2016 12:00;DU

 ;;1.0;TEXT INTEGRATION UTILITIES;**1014,1016,1017**;MAR 20, 2013;Build 7

 ;4/13/13

 ;IHS/MSC/MGH Patch 1016 added normal/abnormal qualifier

 ;

 Q

VPOV(TARGET) ; returns diagnoses for current vuecentric visit context

 ;I $T(GETVAR^CIAVMEVT)="" S @TARGET@(1,0)="Invalid context variables" Q "~@"_$NA(@TARGET)

 NEW VST,I,X,CNT,RESULT

 S VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")

 I VST="" S @TARGET@(1,0)="Invalid visit" Q "~@"_$NA(@TARGET)

 S X="BEHOENCX" X ^%ZOSF("TEST") I $T S VST=+$$VSTR2VIS^BEHOENCX(DFN,VST) I VST<1  S @TARGET@(1,0)="Invalid visit" Q "~@"_$NA(@TARGET)

 D GETPOV(.RESULT,VST)

 ;

 K @TARGET S CNT=0

 S I=0 F  S I=$O(RESULT(I)) Q:'I  D

 .S CNT=CNT+1

 .S @TARGET@(CNT,0)=RESULT(I)

 I 'CNT S @TARGET@(1,0)="No Diagnoses Found"

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

 ;

GETPOV(RETURN,VIEN) ;return every diagnosis for current visit

 ; VISIT=Visit IEN

 ;

 NEW IEN,AIEN,FNUM,STAT,STRING,CNT,BTIU,LINE,ASTHMA,PCNT,CODE,PAT,CON,NARR,IEN2,Q,ARRAY,ENTER,SNO

 K RETURN

 ;

 S IEN=0 F  S IEN=$O(^AUPNVPOV("AD",VIEN,IEN)) Q:'IEN  D

 . S ASTHMA=0

 . S NARR=$$GET1^DIQ(9000010.07,IEN,.04)

 . I $P(NARR,"|",1)["*" S NARR=$P(NARR,"|",2)

 . I $P(NARR,"|",2)=" " S NARR=$P(NARR,"|",1)

 . S STAT=$$GET1^DIQ(9000010.07,IEN,.12,"I")

 . S ENTER=$$GET1^DIQ(9000010.07,IEN,1216,"I")

 . S ARRAY(STAT,ENTER,NARR,IEN)=""

 S STAT="",IEN=0

 F  S STAT=$O(ARRAY(STAT)) Q:STAT=""  D

 .S ENTER="" F  S ENTER=$O(ARRAY(STAT,ENTER)) Q:ENTER=""  D

 ..S NARR="" F  S NARR=$O(ARRAY(STAT,ENTER,NARR)) Q:NARR=""  D

 ...S IEN=0 S IEN=$O(ARRAY(STAT,ENTER,NARR,IEN)) Q:IEN=""  D    ;Only get the first one

 .... S CNT=$G(CNT)+1,PCNT=$G(PCNT)+1

 .... K BTIU D ENP^XBDIQ1(9000010.07,IEN,".01:.29;1102","BTIU(","IE")

 .... S LINE=""

 .... I (BTIU(.12)="PRIMARY") S LINE=" [P] "         ;mark if primary dx

 .... S CODE=$G(BTIU(.01))

 .... S SNO=$G(BTIU(1102))

 .... S ASTHMA=$$CHECK^BGOASLK(CODE,SNO)

 .... I +ASTHMA D

 ..... S PAT=BTIU(.02,"I")

 ..... S CON=$$ACONTROL^BTIULO5(PAT)

 ..... I CON'="" S LINE=LINE_" Control: "_CON

 .... F I=.06,.05,.09,.13,.11,.29 D                   ;check for other fields

 ..... I (I=.09),BTIU(.09)]"" S LINE=LINE_"; "_$$ECODE^BTIULO5(IEN) Q

 ..... I BTIU(I)]"" S LINE=LINE_"; "_BTIU(I)

 .... S RETURN(CNT)=$J(PCNT,2)_") "_NARR_LINE

 .... ;Return qualifiers

 ....F X=13,17,18,14 D

 .....S STRING=""

 .....S IEN2=0 F  S IEN2=$O(^AUPNVPOV(IEN,X,IEN2)) Q:'+IEN2  D

 ......S Q=""

 ......S FNUM=$S(X=13:9000010.0713,X=17:9000010.0717,X=18:9000010.0718,X=14:9000010.0714)

 ......S AIEN=IEN2_","_IEN_","

 ......S Q=$$GET1^DIQ(FNUM,AIEN,.01)

 ......S Q=$P($$CONC^BSTSAPI(Q_"^^^1"),U,4)

 ......S STRING=$S(STRING="":Q,1:STRING_" "_Q)

 .....I STRING'="" D

 ......S CNT=CNT+1

 ......S RETURN(CNT)="    "_STRING

 Q

 ;

VOB(DFN,PRIEN,VIEN,CNT) ; V OB notes by date

 N INVDT,IEN,EDATE,SIGN,STAT,FOUND,SDATE,EIE,SIGNDT,VSCNT

 S FOUND=0,SDATE="",VSCNT=0

 S VIEN=$G(VIEN)

 S INVDT="" F  S INVDT=$O(^AUPNVOB("AE",DFN,PRIEN,INVDT)) Q:INVDT=""!(FOUND=1)  D

 .I +SDATE,SDATE'=$P(INVDT,".",1) S FOUND=1

 .S IEN="" F  S IEN=$O(^AUPNVOB("AE",DFN,PRIEN,INVDT,IEN)) Q:IEN=""  D

 ..S EIE=$$GET1^DIQ(9000010.43,IEN,.06,"I")

 ..Q:EIE=1

 ..S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)

 ..Q:STAT="D"

 ..Q:+VIEN&(VIEN'=$P($G(^AUPNVOB(IEN,0)),U,3))

 ..I VSCNT=0 S VSCNT=VSCNT+1 D ADD("   -OB NOTE:")

 ..S EDATE=9999999-INVDT

 ..S EDATE=$$FMTE^XLFDT($P(EDATE,".",1),5)

 ..S SIGNDT=$$GET1^DIQ(9000010.43,IEN,.05,"I")

 ..S SIGNDT=$$FMTE^XLFDT($P(SIGNDT,".",1),5)

 ..S SIGN=$$GET1^DIQ(9000010.43,IEN,.04,"E")

 ..D TEXT2(IEN)

 Q

ADD(DATA) ;add to list

 S CNT=CNT+1

 S @TARGET@(CNT,0)=DATA

 Q

TEXT2(IEN) ;do the text

 N TXTIEN,WRAP,TXT,PRNT2,PRNT

 S (PRNT,PRNT2,WRAP)=""

 S TXTIEN=0 F  S TXTIEN=$O(^AUPNVOB(IEN,11,TXTIEN)) Q:'+TXTIEN  D

 .S TXT=$G(^AUPNVOB(IEN,11,TXTIEN,0))

 .S PRNT=PRNT2_TXT S PRNT2=""

 .I $L(PRNT)>500 S PRNT2=$E(PRNT,501,$L(PRNT))

 .D WRAP^BTIUPV1(.WRAP,PRNT,70)

 ;Process each wrapped line

 I $D(WRAP)>1 D PROC(.WRAP)

 Q

PROC(WRAP) ;Process the word wrap

 N I,LINE

 F I=1:1:WRAP D

 .I I=WRAP D

 ..I $L(WRAP(I))<45 D

 ...S LINE="   "_$G(WRAP(I))_" ("_SIGNDT_" by "_SIGN_")"

 ...D ADD(LINE)

 ..E  D

 ...D ADD("   "_$G(WRAP(I)))

 ...D ADD("   ("_SIGNDT_" by "_SIGN_")")

 .E  D ADD("   "_$G(WRAP(I)))

 Q

BTIUPV2   ; IHS/MSC/MGH - Problem Objects ;16-Aug-2016 12:00;DU

 +1       ;;1.0;TEXT INTEGRATION UTILITIES;**1014,1016,1017**;MAR 20, 2013;Build 7

 +2       ;4/13/13

 +3       ;IHS/MSC/MGH Patch 1016 added normal/abnormal qualifier

 +4       ;

 +5        QUIT 

VPOV(TARGET) ; returns diagnoses for current vuecentric visit context

 +1       ;I $T(GETVAR^CIAVMEVT)="" S @TARGET@(1,0)="Invalid context variables" Q "~@"_$NA(@TARGET)

 +2        NEW VST,I,X,CNT,RESULT

 +3        SET VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")

 +4        IF VST=""

               SET @TARGET@(1,0)="Invalid visit"

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

 +5        SET X="BEHOENCX"

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               SET VST=+$$VSTR2VIS^BEHOENCX(DFN,VST)

               IF VST<1

                   SET @TARGET@(1,0)="Invalid visit"

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

 +6        DO GETPOV(.RESULT,VST)

 +7       ;

 +8        KILL @TARGET

           SET CNT=0

 +9        SET I=0

           FOR 

               SET I=$ORDER(RESULT(I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +10               SET CNT=CNT+1

 +11               SET @TARGET@(CNT,0)=RESULT(I)

               End DoDot:1

 +12       IF 'CNT

               SET @TARGET@(1,0)="No Diagnoses Found"

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

 +14      ;

GETPOV(RETURN,VIEN) ;return every diagnosis for current visit

 +1       ; VISIT=Visit IEN

 +2       ;

 +3        NEW IEN,AIEN,FNUM,STAT,STRING,CNT,BTIU,LINE,ASTHMA,PCNT,CODE,PAT,CON,NARR,IEN2,Q,ARRAY,ENTER,SNO

 +4        KILL RETURN

 +5       ;

 +6        SET IEN=0

           FOR 

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

               IF 'IEN

                   QUIT 

               Begin DoDot:1

 +7                SET ASTHMA=0

 +8                SET NARR=$$GET1^DIQ(9000010.07,IEN,.04)

 +9                IF $PIECE(NARR,"|",1)["*"

                       SET NARR=$PIECE(NARR,"|",2)

 +10               IF $PIECE(NARR,"|",2)=" "

                       SET NARR=$PIECE(NARR,"|",1)

 +11               SET STAT=$$GET1^DIQ(9000010.07,IEN,.12,"I")

 +12               SET ENTER=$$GET1^DIQ(9000010.07,IEN,1216,"I")

 +13               SET ARRAY(STAT,ENTER,NARR,IEN)=""

               End DoDot:1

 +14       SET STAT=""

           SET IEN=0

 +15       FOR 

               SET STAT=$ORDER(ARRAY(STAT))

               IF STAT=""

                   QUIT 

               Begin DoDot:1

 +16               SET ENTER=""

                   FOR 

                       SET ENTER=$ORDER(ARRAY(STAT,ENTER))

                       IF ENTER=""

                           QUIT 

                       Begin DoDot:2

 +17                       SET NARR=""

                           FOR 

                               SET NARR=$ORDER(ARRAY(STAT,ENTER,NARR))

                               IF NARR=""

                                   QUIT 

                               Begin DoDot:3

 +18      ;Only get the first one

                                   SET IEN=0

                                   SET IEN=$ORDER(ARRAY(STAT,ENTER,NARR,IEN))

                                   IF IEN=""

                                       QUIT 

                                   Begin DoDot:4

 +19                                   SET CNT=$GET(CNT)+1

                                       SET PCNT=$GET(PCNT)+1

 +20                                   KILL BTIU

                                       DO ENP^XBDIQ1(9000010.07,IEN,".01:.29;1102","BTIU(","IE")

 +21                                   SET LINE=""

 +22      ;mark if primary dx

                                       IF (BTIU(.12)="PRIMARY")

                                           SET LINE=" [P] "

 +23                                   SET CODE=$GET(BTIU(.01))

 +24                                   SET SNO=$GET(BTIU(1102))

 +25                                   SET ASTHMA=$$CHECK^BGOASLK(CODE,SNO)

 +26                                   IF +ASTHMA

                                           Begin DoDot:5

 +27                                           SET PAT=BTIU(.02,"I")

 +28                                           SET CON=$$ACONTROL^BTIULO5(PAT)

 +29                                           IF CON'=""

                                                   SET LINE=LINE_" Control: "_CON

                                           End DoDot:5

 +30      ;check for other fields

                                       FOR I=.06,.05,.09,.13,.11,.29

                                           Begin DoDot:5

 +31                                           IF (I=.09)

                                                   IF BTIU(.09)]""

                                                       SET LINE=LINE_"; "_$$ECODE^BTIULO5(IEN)

                                                       QUIT 

 +32                                           IF BTIU(I)]""

                                                   SET LINE=LINE_"; "_BTIU(I)

                                           End DoDot:5

 +33                                   SET RETURN(CNT)=$JUSTIFY(PCNT,2)_") "_NARR_LINE

 +34      ;Return qualifiers

 +35                                   FOR X=13,17,18,14

                                           Begin DoDot:5

 +36                                           SET STRING=""

 +37                                           SET IEN2=0

                                               FOR 

                                                   SET IEN2=$ORDER(^AUPNVPOV(IEN,X,IEN2))

                                                   IF '+IEN2

                                                       QUIT 

                                                   Begin DoDot:6

 +38                                                   SET Q=""

 +39                                                   SET FNUM=$SELECT(X=13:9000010.0713,X=17:9000010.0717,X=18:9000010.0718,X=14:9000010.0714)

 +40                                                   SET AIEN=IEN2_","_IEN_","

 +41                                                   SET Q=$$GET1^DIQ(FNUM,AIEN,.01)

 +42                                                   SET Q=$PIECE($$CONC^BSTSAPI(Q_"^^^1"),U,4)

 +43                                                   SET STRING=$SELECT(STRING="":Q,1:STRING_" "_Q)

                                                   End DoDot:6

 +44                                           IF STRING'=""

                                                   Begin DoDot:6

 +45                                                   SET CNT=CNT+1

 +46                                                   SET RETURN(CNT)="    "_STRING

                                                   End DoDot:6

                                           End DoDot:5

                                   End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +47       QUIT 

 +48      ;

VOB(DFN,PRIEN,VIEN,CNT) ; V OB notes by date

 +1        NEW INVDT,IEN,EDATE,SIGN,STAT,FOUND,SDATE,EIE,SIGNDT,VSCNT

 +2        SET FOUND=0

           SET SDATE=""

           SET VSCNT=0

 +3        SET VIEN=$GET(VIEN)

 +4        SET INVDT=""

           FOR 

               SET INVDT=$ORDER(^AUPNVOB("AE",DFN,PRIEN,INVDT))

               IF INVDT=""!(FOUND=1)

                   QUIT 

               Begin DoDot:1

 +5                IF +SDATE

                       IF SDATE'=$PIECE(INVDT,".",1)

                           SET FOUND=1

 +6                SET IEN=""

                   FOR 

                       SET IEN=$ORDER(^AUPNVOB("AE",DFN,PRIEN,INVDT,IEN))

                       IF IEN=""

                           QUIT 

                       Begin DoDot:2

 +7                        SET EIE=$$GET1^DIQ(9000010.43,IEN,.06,"I")

 +8                        IF EIE=1

                               QUIT 

 +9                        SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)

 +10                       IF STAT="D"

                               QUIT 

 +11                       IF +VIEN&(VIEN'=$PIECE($GET(^AUPNVOB(IEN,0)),U,3))

                               QUIT 

 +12                       IF VSCNT=0

                               SET VSCNT=VSCNT+1

                               DO ADD("   -OB NOTE:")

 +13                       SET EDATE=9999999-INVDT

 +14                       SET EDATE=$$FMTE^XLFDT($PIECE(EDATE,".",1),5)

 +15                       SET SIGNDT=$$GET1^DIQ(9000010.43,IEN,.05,"I")

 +16                       SET SIGNDT=$$FMTE^XLFDT($PIECE(SIGNDT,".",1),5)

 +17                       SET SIGN=$$GET1^DIQ(9000010.43,IEN,.04,"E")

 +18                       DO TEXT2(IEN)

                       End DoDot:2

               End DoDot:1

 +19       QUIT 

ADD(DATA) ;add to list

 +1        SET CNT=CNT+1

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

 +3        QUIT 

TEXT2(IEN) ;do the text

 +1        NEW TXTIEN,WRAP,TXT,PRNT2,PRNT

 +2        SET (PRNT,PRNT2,WRAP)=""

 +3        SET TXTIEN=0

           FOR 

               SET TXTIEN=$ORDER(^AUPNVOB(IEN,11,TXTIEN))

               IF '+TXTIEN

                   QUIT 

               Begin DoDot:1

 +4                SET TXT=$GET(^AUPNVOB(IEN,11,TXTIEN,0))

 +5                SET PRNT=PRNT2_TXT

                   SET PRNT2=""

 +6                IF $LENGTH(PRNT)>500

                       SET PRNT2=$EXTRACT(PRNT,501,$LENGTH(PRNT))

 +7                DO WRAP^BTIUPV1(.WRAP,PRNT,70)

               End DoDot:1

 +8       ;Process each wrapped line

 +9        IF $DATA(WRAP)>1

               DO PROC(.WRAP)

 +10       QUIT 

PROC(WRAP) ;Process the word wrap

 +1        NEW I,LINE

 +2        FOR I=1:1:WRAP

               Begin DoDot:1

 +3                IF I=WRAP

                       Begin DoDot:2

 +4                        IF $LENGTH(WRAP(I))<45

                               Begin DoDot:3

 +5                                SET LINE="   "_$GET(WRAP(I))_" ("_SIGNDT_" by "_SIGN_")"

 +6                                DO ADD(LINE)

                               End DoDot:3

 +7                       IF '$TEST

                               Begin DoDot:3

 +8                                DO ADD("   "_$GET(WRAP(I)))

 +9                                DO ADD("   ("_SIGNDT_" by "_SIGN_")")

                               End DoDot:3

                       End DoDot:2

 +10              IF '$TEST

                       DO ADD("   "_$GET(WRAP(I)))

               End DoDot:1

 +11       QUIT