BTIUPDD2 ; IHS/MSC/MGH - Problem Objects by entry date ;24-May-2016 08:55;DU
;;1.0;TEXT INTEGRATION UTILITIES;**1017**;MAR 20, 2013;Build 7
;
Q
;
;
;Get the problems associated with this visit and only the latest or items updated during this visit
VST(DFN,TARGET,VIEN,CP,OB) ;Problems updated this visit
N PROB,CNT,RET,I,VST
S CNT=0,CP=$G(CP),OB=$G(OB)
K @TARGET
S VIEN=$G(VIEN)
I VIEN'="" G GETPRB
S VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
I VST="" S @TARGET@(1,0)="Invalid visit" Q "~@"_$NA(@TARGET)
S VIEN=+$$VSTR2VIS^BEHOENCX(DFN,VST) I VST<1 S @TARGET@(1,0)="Invalid context variables" Q "~@"_$NA(@TARGET)
D GETPRB
I CNT=0 S @TARGET@(1,0)="No Problems used as POVs in this visit record"
Q "~@"_$NA(@TARGET)
;
GETPRB ;Get problems to update
N POV,PRIEN,PCNT,ARRAY
S ARRAY=""
I $G(VIEN)="" S @TARGET@(1,0)="Invalid visit" Q "~@"_$NA(@TARGET)
S PCNT=0,PRIEN=0
F S PRIEN=$O(^AUPNPROB("AC",DFN,PRIEN)) Q:'PRIEN D
.;Check for which statuses to return
.S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
.Q:STAT="D"
.I $D(^AUPNPROB(PRIEN,14,"B",VIEN)) D
..D GETDATA(.ARRAY,PRIEN,VIEN)
;IHS/MSC/MGH Patch 1014
D ADDITMS(.ARRAY)
Q
GETDATA(ARRAY,PRIEN,VIEN) ;Get data for a problem
N NARR,STATUS,ICD
Q:'+PRIEN
S NARR=$$POV^BTIUPDD(VIEN,PRIEN)
Q:$P(NARR,U,1)=""!($P(NARR,U,2)="")!($P(NARR,U,3)="")
S ARRAY($P(NARR,U,2),$P(NARR,U,3),$P(NARR,U,1),PRIEN)=""
Q
;S NARR=$$GET1^DIQ(9000010.07,POV,.04)
ADDITMS(ARRAY) ;Get items in order
N STAT,NARR,PRIEN,ENTRY
S STAT="" F S STAT=$O(ARRAY(STAT)) Q:STAT="" D
.S ENTRY="" F S ENTRY=$O(ARRAY(STAT,ENTRY)) Q:ENTRY="" D
..S NARR="" F S NARR=$O(ARRAY(STAT,ENTRY,NARR)) Q:NARR="" D
...S PRIEN="" F S PRIEN=$O(ARRAY(STAT,ENTRY,NARR,PRIEN)) Q:PRIEN="" D
....S PCNT=PCNT+1
....D ADD($J(PCNT,2)_")"_NARR_" "_"("_STAT_")")
....D QUAL^BTIUPV1(PRIEN,.CNT)
....I CP=1 D
.....D FINDCP^BTIUPV1(PRIEN,"G",.CNT) ;Add goals
.....D FINDCP^BTIUPV1(PRIEN,"P",.CNT) ;Add care plans
....I CP=2 D
.....D FINDCP(PRIEN,"G",.CNT)
.....D FINDCP(PRIEN,"P",.CNT)
....D VIDT^BTIUPV1(PRIEN,VIEN,.CNT) ;Visit instruction
....I +OB D VOB^BTIUPV2(DFN,PRIEN,VIEN,.CNT) ;V OB notes
....D VTRDT^BTIUPV1(PRIEN,VIEN,.CNT) ;V treatment/regimens
....D REFDT^BTIUPV1(PRIEN,VIEN,.CNT) ;V REFERRALS
....D EDU^BTIUPV1(PRIEN,VIEN,.CNT) ;V education by date
Q
FINDCP(PRIEN,TYPE,CNT) ;Find a care plan for today Patch 1013
N INVDT,INVDT2,SIGNDT,ARRDT,STATUS,EDATE,IEN,NODE,PRV,PRVNM,INVDT,CPIEN,CVTDT,SIGN,NODE,Z,DONE,SIEN,PCNT,ARRAY
S DONE=0,PCNT=0,ARRAY=""
S INVDT="" S INVDT=$O(^AUPNCPL("APDT",PRIEN,TYPE,INVDT))
Q:INVDT=""
S CVTDT=9999999-INVDT
Q:$P(CVTDT,".",1)'=DT
S CPIEN="" F S CPIEN=$O(^AUPNCPL("APDT",PRIEN,TYPE,INVDT,CPIEN)) Q:CPIEN="" D
.S SIEN=$C(0) S SIEN=$O(^AUPNCPL(CPIEN,11,SIEN),-1)
.S STATUS=$P($G(^AUPNCPL(CPIEN,11,SIEN,0)),U,1)
.Q:STATUS'="A"
.S INVDT2=9999999-$P($G(^AUPNCPL(CPIEN,0)),U,5)
.S ARRAY(INVDT2,CPIEN)=""
Q:$D(ARRAY)<10
S ARRDT="" F S ARRDT=$O(ARRAY(ARRDT)) Q:'+ARRDT D
.S CPIEN="" F S CPIEN=$O(ARRAY(ARRDT,CPIEN)) Q:'+CPIEN D
..I PCNT=0 S PCNT=1 D
...I TYPE="P" D ADD(" -CARE PLANS:")
...I TYPE="G" D ADD(" -GOALS:")
..S NODE=$G(^AUPNCPL(CPIEN,0))
..S PRV=$$GET1^DIQ(9000092,CPIEN,.03,"I")
..S PRVNM=$$GET1^DIQ(9000092,CPIEN,.03)
..S SIGNDT=$$GET1^DIQ(9000092,CPIEN,.08,"I")
..S SIGNDT=$$FMTE^XLFDT($P(SIGNDT,".",1),5)
..S SIGN=$$GET1^DIQ(9000092,CPIEN,.07)
..S EDATE=$$GET1^DIQ(9000092,CPIEN,.05)
..Q:SIGN=""&(PRV'=DUZ)
..D TEXT^BTIUPV1(TYPE,CPIEN)
Q
;
POV(VIEN,PRIEN) ;Check to see if POV narrative is different from problem narrative
;IHS/MSC/MGH added normal/abnormal qualifier
N POV,POVIEN,MATCH,PRIM,NORM,STR,ENTER
S MATCH=0,POV=""
S POVIEN="",STR=""
F S POVIEN=$O(^AUPNVPOV("AD",VIEN,POVIEN)) Q:POVIEN=""!(MATCH=1) D
.I $P($G(^AUPNVPOV(POVIEN,0)),U,16)=PRIEN S MATCH=1
.S POV=$$GET1^DIQ(9000010.07,POVIEN,.04)
.S PRIM=$$GET1^DIQ(9000010.07,POVIEN,.12,"I")
.S NORM=$$GET1^DIQ(9000010.07,POVIEN,.29,"E")
.S ENTER=$$GET1^DIQ(9000010.07,POVIEN,1216,"I")
.I NORM="" S STR=POV_U_PRIM
.I NORM'="" S STR=POV_";"_NORM_U_PRIM
.S STR=STR_U_ENTER
Q STR
ADD(DATA) ;add to list
S CNT=CNT+1
S @TARGET@(CNT,0)=DATA
Q
TMPGBL(X) ;EP
K ^TMP("BGOPRDD",$J) Q $NA(^($J))
BTIUPDD2 ; IHS/MSC/MGH - Problem Objects by entry date ;24-May-2016 08:55;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1017**;MAR 20, 2013;Build 7
+2 ;
+3 QUIT
+4 ;
+5 ;
+6 ;Get the problems associated with this visit and only the latest or items updated during this visit
VST(DFN,TARGET,VIEN,CP,OB) ;Problems updated this visit
+1 NEW PROB,CNT,RET,I,VST
+2 SET CNT=0
SET CP=$GET(CP)
SET OB=$GET(OB)
+3 KILL @TARGET
+4 SET VIEN=$GET(VIEN)
+5 IF VIEN'=""
GOTO GETPRB
+6 SET VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
+7 IF VST=""
SET @TARGET@(1,0)="Invalid visit"
QUIT "~@"_$NAME(@TARGET)
+8 SET VIEN=+$$VSTR2VIS^BEHOENCX(DFN,VST)
IF VST<1
SET @TARGET@(1,0)="Invalid context variables"
QUIT "~@"_$NAME(@TARGET)
+9 DO GETPRB
+10 IF CNT=0
SET @TARGET@(1,0)="No Problems used as POVs in this visit record"
+11 QUIT "~@"_$NAME(@TARGET)
+12 ;
GETPRB ;Get problems to update
+1 NEW POV,PRIEN,PCNT,ARRAY
+2 SET ARRAY=""
+3 IF $GET(VIEN)=""
SET @TARGET@(1,0)="Invalid visit"
QUIT "~@"_$NAME(@TARGET)
+4 SET PCNT=0
SET PRIEN=0
+5 FOR
SET PRIEN=$ORDER(^AUPNPROB("AC",DFN,PRIEN))
IF 'PRIEN
QUIT
Begin DoDot:1
+6 ;Check for which statuses to return
+7 SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+8 IF STAT="D"
QUIT
+9 IF $DATA(^AUPNPROB(PRIEN,14,"B",VIEN))
Begin DoDot:2
+10 DO GETDATA(.ARRAY,PRIEN,VIEN)
End DoDot:2
End DoDot:1
+11 ;IHS/MSC/MGH Patch 1014
+12 DO ADDITMS(.ARRAY)
+13 QUIT
GETDATA(ARRAY,PRIEN,VIEN) ;Get data for a problem
+1 NEW NARR,STATUS,ICD
+2 IF '+PRIEN
QUIT
+3 SET NARR=$$POV^BTIUPDD(VIEN,PRIEN)
+4 IF $PIECE(NARR,U,1)=""!($PIECE(NARR,U,2)="")!($PIECE(NARR,U,3)="")
QUIT
+5 SET ARRAY($PIECE(NARR,U,2),$PIECE(NARR,U,3),$PIECE(NARR,U,1),PRIEN)=""
+6 QUIT
+7 ;S NARR=$$GET1^DIQ(9000010.07,POV,.04)
ADDITMS(ARRAY) ;Get items in order
+1 NEW STAT,NARR,PRIEN,ENTRY
+2 SET STAT=""
FOR
SET STAT=$ORDER(ARRAY(STAT))
IF STAT=""
QUIT
Begin DoDot:1
+3 SET ENTRY=""
FOR
SET ENTRY=$ORDER(ARRAY(STAT,ENTRY))
IF ENTRY=""
QUIT
Begin DoDot:2
+4 SET NARR=""
FOR
SET NARR=$ORDER(ARRAY(STAT,ENTRY,NARR))
IF NARR=""
QUIT
Begin DoDot:3
+5 SET PRIEN=""
FOR
SET PRIEN=$ORDER(ARRAY(STAT,ENTRY,NARR,PRIEN))
IF PRIEN=""
QUIT
Begin DoDot:4
+6 SET PCNT=PCNT+1
+7 DO ADD($JUSTIFY(PCNT,2)_")"_NARR_" "_"("_STAT_")")
+8 DO QUAL^BTIUPV1(PRIEN,.CNT)
+9 IF CP=1
Begin DoDot:5
+10 ;Add goals
DO FINDCP^BTIUPV1(PRIEN,"G",.CNT)
+11 ;Add care plans
DO FINDCP^BTIUPV1(PRIEN,"P",.CNT)
End DoDot:5
+12 IF CP=2
Begin DoDot:5
+13 DO FINDCP(PRIEN,"G",.CNT)
+14 DO FINDCP(PRIEN,"P",.CNT)
End DoDot:5
+15 ;Visit instruction
DO VIDT^BTIUPV1(PRIEN,VIEN,.CNT)
+16 ;V OB notes
IF +OB
DO VOB^BTIUPV2(DFN,PRIEN,VIEN,.CNT)
+17 ;V treatment/regimens
DO VTRDT^BTIUPV1(PRIEN,VIEN,.CNT)
+18 ;V REFERRALS
DO REFDT^BTIUPV1(PRIEN,VIEN,.CNT)
+19 ;V education by date
DO EDU^BTIUPV1(PRIEN,VIEN,.CNT)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT
FINDCP(PRIEN,TYPE,CNT) ;Find a care plan for today Patch 1013
+1 NEW INVDT,INVDT2,SIGNDT,ARRDT,STATUS,EDATE,IEN,NODE,PRV,PRVNM,INVDT,CPIEN,CVTDT,SIGN,NODE,Z,DONE,SIEN,PCNT,ARRAY
+2 SET DONE=0
SET PCNT=0
SET ARRAY=""
+3 SET INVDT=""
SET INVDT=$ORDER(^AUPNCPL("APDT",PRIEN,TYPE,INVDT))
+4 IF INVDT=""
QUIT
+5 SET CVTDT=9999999-INVDT
+6 IF $PIECE(CVTDT,".",1)'=DT
QUIT
+7 SET CPIEN=""
FOR
SET CPIEN=$ORDER(^AUPNCPL("APDT",PRIEN,TYPE,INVDT,CPIEN))
IF CPIEN=""
QUIT
Begin DoDot:1
+8 SET SIEN=$CHAR(0)
SET SIEN=$ORDER(^AUPNCPL(CPIEN,11,SIEN),-1)
+9 SET STATUS=$PIECE($GET(^AUPNCPL(CPIEN,11,SIEN,0)),U,1)
+10 IF STATUS'="A"
QUIT
+11 SET INVDT2=9999999-$PIECE($GET(^AUPNCPL(CPIEN,0)),U,5)
+12 SET ARRAY(INVDT2,CPIEN)=""
End DoDot:1
+13 IF $DATA(ARRAY)<10
QUIT
+14 SET ARRDT=""
FOR
SET ARRDT=$ORDER(ARRAY(ARRDT))
IF '+ARRDT
QUIT
Begin DoDot:1
+15 SET CPIEN=""
FOR
SET CPIEN=$ORDER(ARRAY(ARRDT,CPIEN))
IF '+CPIEN
QUIT
Begin DoDot:2
+16 IF PCNT=0
SET PCNT=1
Begin DoDot:3
+17 IF TYPE="P"
DO ADD(" -CARE PLANS:")
+18 IF TYPE="G"
DO ADD(" -GOALS:")
End DoDot:3
+19 SET NODE=$GET(^AUPNCPL(CPIEN,0))
+20 SET PRV=$$GET1^DIQ(9000092,CPIEN,.03,"I")
+21 SET PRVNM=$$GET1^DIQ(9000092,CPIEN,.03)
+22 SET SIGNDT=$$GET1^DIQ(9000092,CPIEN,.08,"I")
+23 SET SIGNDT=$$FMTE^XLFDT($PIECE(SIGNDT,".",1),5)
+24 SET SIGN=$$GET1^DIQ(9000092,CPIEN,.07)
+25 SET EDATE=$$GET1^DIQ(9000092,CPIEN,.05)
+26 IF SIGN=""&(PRV'=DUZ)
QUIT
+27 DO TEXT^BTIUPV1(TYPE,CPIEN)
End DoDot:2
End DoDot:1
+28 QUIT
+29 ;
POV(VIEN,PRIEN) ;Check to see if POV narrative is different from problem narrative
+1 ;IHS/MSC/MGH added normal/abnormal qualifier
+2 NEW POV,POVIEN,MATCH,PRIM,NORM,STR,ENTER
+3 SET MATCH=0
SET POV=""
+4 SET POVIEN=""
SET STR=""
+5 FOR
SET POVIEN=$ORDER(^AUPNVPOV("AD",VIEN,POVIEN))
IF POVIEN=""!(MATCH=1)
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^AUPNVPOV(POVIEN,0)),U,16)=PRIEN
SET MATCH=1
+7 SET POV=$$GET1^DIQ(9000010.07,POVIEN,.04)
+8 SET PRIM=$$GET1^DIQ(9000010.07,POVIEN,.12,"I")
+9 SET NORM=$$GET1^DIQ(9000010.07,POVIEN,.29,"E")
+10 SET ENTER=$$GET1^DIQ(9000010.07,POVIEN,1216,"I")
+11 IF NORM=""
SET STR=POV_U_PRIM
+12 IF NORM'=""
SET STR=POV_";"_NORM_U_PRIM
+13 SET STR=STR_U_ENTER
End DoDot:1
+14 QUIT STR
ADD(DATA) ;add to list
+1 SET CNT=CNT+1
+2 SET @TARGET@(CNT,0)=DATA
+3 QUIT
TMPGBL(X) ;EP
+1 KILL ^TMP("BGOPRDD",$JOB)
QUIT $NAME(^($JOB))
