BTPWEHIS ;VNGT/HS/ALA-Patient Event History ; 18 Aug 2010 9:56 AM
;;1.2;CARE MANAGEMENT EVENT TRACKING;;Jul 07, 2017;Build 71
;
;
EHIS(DATA,DFN,OCAT) ;EP - BTPW GET PATIENT EVENT HISTORY
;
NEW UID,II,LINK,VSDTM,CAT,PROCNM,WHREC,BREC,WHIEN,HDR,ORD,QFL,REF,RIEN,STAT,TGLOB,VISIT,WIEN,RARPT
NEW ACCN,BQII,D0,DA,DIC,DK,FULLE,FULLR,ECHR,FRIL,I,J,K,LEN,LG,LIEN,LN,PRCN,TAB,VAL,VALUE,VHD
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BTPWEHIS",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S BQII=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BTPWPPAT D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S HDR="T00040CATEGORY^T00060EVENT^D00015EVNT_DATE^T01024EXP_EVENT^D00030RESULT^T01024EXP_RESULT^"
S HDR=HDR_"T01024HIDE_RESULT^T01024INTERPRETATION^T01024HIDE_INTERPRETATION"
S @DATA@(BQII)=HDR_$C(30)
;
S OCAT=$G(OCAT,""),TGLOB=$NA(^XTMP("BTPWPRC"))
;
; If history of all events for this patient
S PRCN="" F S PRCN=$O(@TGLOB@(DFN,PRCN)) Q:PRCN="" D
. Q:PRCN="~"
. ;
. ;Get internal category and filter on inputed category
. S CAT=$$GET1^DIQ(90621,PRCN_",",.1,"I") I OCAT'="",CAT'=OCAT Q
. S CAT=$$CAT^BTPWPDSP(PRCN) ;Get external Category
. D LEVT(PRCN,CAT)
;
DONE ;
S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
LEVT(PRCN,CAT) ;EP - Get event
N EXVDT,INTR,HINTR,HLINK
S VSDTM="",PROCNM=$P(^BTPW(90621,PRCN,0),U,1)
S WHREC="",RARPT="",LINK="",ACCN=""
F S VSDTM=$O(@TGLOB@(DFN,PRCN,VSDTM)) Q:VSDTM="" D
. S ORD=""
. S ORD=$O(@TGLOB@(DFN,PRCN,VSDTM,ORD)) Q:ORD="" D Q:'QFL
.. S VISIT="",QFL=1
.. S VISIT=$O(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT)) Q:VISIT="" D Q:'QFL
... S RIEN="",STAT="",RARPT="",ACCN=""
... S RIEN=$O(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN)) Q:RIEN="" D Q:'QFL
.... S WHIEN="",BREC(VSDTM)=RIEN,WHREC=""
.... I $G(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN))="" D
..... S WIEN=$O(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,""))
..... S WHIEN=$P(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,WIEN),U,1)
..... S REF=$P(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,WIEN),U,2,3)
..... S RARPT=$P(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,WIEN),U,4)
.... I $G(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN))'="" D
..... S WHIEN=$P(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN),U,1)
..... S REF=$P(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN),U,2,3)
..... S RARPT=$P(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN),U,4)
... ;
... ; Look for entry in Tracked file - pull interpretation
... S (HINTR,INTR)=""
... S FRIL=$P(REF,U,2) S:FRIL]"" FRIL=$O(^BTPW(90621.1,"B",FRIL,""))
... I DFN'="",PRCN'="",VISIT'="",RIEN'="",FRIL'="" D
.... N TIEN
.... S TIEN=$O(^BTPWP("C",DFN,PRCN,VISIT,RIEN,FRIL,""))
.... I TIEN]"" S INTR=$$INTER^BTPWPEVT(TIEN),HINTR=$P(INTR,$C(26),2),INTR=$P(INTR,$C(26))
... ;
... S:VISIT="~" VISIT=""
... ; pull interpretation if WH record
... I $G(INTR)="",WHIEN'="" S INTR=$$INTER^BTPWPEVT("",WHIEN),HINTR=$P(INTR,$C(26),2),INTR=$P(INTR,$C(26))
... S RIEN=$G(BREC(VSDTM))
... S EXVDT=$$FMTE^BQIUL1(VSDTM)
... I $P(REF,U,1)=9000010.09 D
.... I RIEN'="~",RIEN'="",WHIEN="" S ACCN=$P($G(^AUPNVLAB(RIEN,0)),U,6)
.... I $E(ACCN,1,2)="WH" S WHIEN=$O(^BPWCD("B",$E(ACCN,3,$L(ACCN)),"")) I WHIEN'="" S ACCN=""
... S FULLR=""
... ; If V LAB but now RIEN and WH IEN
... I ACCN="",WHIEN'="" S $P(REF,U,2)="WH RECORD"
... ; If WH record but no result has been entered
... ;I WHIEN'="",$P($G(^BWPCD(WHIEN,0)),U,5)="" S WHIEN=""
... S LINK=""
... I WHIEN'="" S LINK=EXVDT_$C(28)_$P(REF,U,2)_$C(28)_"W:"_WHIEN
... I RARPT'="" S LINK=EXVDT_$C(28)_$P(REF,U,2)_$C(28)_"R:"_RARPT
... I WHIEN'="" D
.... NEW TDATA
.... D EN^BTPWRWHP(.TDATA,WHIEN)
.... F I=1:1 Q:@TDATA@(I)=$C(30) S FULLR=FULLR_@TDATA@(I)
... I RARPT'="" D
.... NEW TDATA
.... D EN^BTPWRRAD(.TDATA,DFN,RARPT)
.... F I=1:1 Q:@TDATA@(I)=$C(30) S FULLR=FULLR_@TDATA@(I)
... I ACCN'="" D
.... NEW RES
.... S RES=$P($G(^AUPNVLAB(RIEN,0)),U,4)
.... NEW TDATA
.... D EN^BTPWRLAB(.TDATA,DFN,RIEN)
.... F I=1:1 Q:@TDATA@(I)=$C(30) S FULLR=FULLR_@TDATA@(I)
.... I RES="",$P($G(^AUPNVLAB(RIEN,11)),U,9)'="R" Q
.... S LINK=EXVDT_$C(28)_$P(REF,U,2)_$C(28)_"L:"_RIEN
... S HLINK=$P(LINK,$C(28),2,3),LINK=$P(LINK,$C(28))
... S FULLE="Event obtained from: "_$C(13)_$C(10) D
.... I WHIEN'="" S FULLE=FULLE_"Women's Health Package" Q
.... S FULLE=FULLE_$P(^BTPW(90621.1,FRIL,0),"^",1)_" - "
.... NEW FIL,FLD
.... S FIL=$P(^BTPW(90621.1,FRIL,0),"^",2),FLD=$P(^(0),"^",3),TAB=$P(^(0),"^",8)
.... S FULLE=FULLE_$$GET1^DIQ(FIL,RIEN_",",FLD,"E")
.... S LIEN=$$GET1^DIQ(FIL,RIEN_",",FLD,"I")
.... I TAB=80!(TAB=80.1)!(TAB=81) D
.... I TAB=80 S FULLE=FULLE_" "_$$ICD9^BQIUL3(LIEN,,4)_$C(13)_$C(10) Q
.... I TAB=80.1 S FULLE=FULLE_" "_$$ICD0^BQIUL3(LIEN,,5)_$C(13)_$C(10) Q
.... I TAB=81 S FULLE=FULLE_" "_$$ICPT^BQIUL3(LIEN,"",3)
... S BQII=BQII+1,@DATA@(BQII)=CAT_U_PROCNM_U_EXVDT_U_FULLE_U_LINK_U_FULLR_U_HLINK_U_INTR_U_HINTR_$C(30)
Q
BTPWEHIS ;VNGT/HS/ALA-Patient Event History ; 18 Aug 2010 9:56 AM
+1 ;;1.2;CARE MANAGEMENT EVENT TRACKING;;Jul 07, 2017;Build 71
+2 ;
+3 ;
EHIS(DATA,DFN,OCAT) ;EP - BTPW GET PATIENT EVENT HISTORY
+1 ;
+2 NEW UID,II,LINK,VSDTM,CAT,PROCNM,WHREC,BREC,WHIEN,HDR,ORD,QFL,REF,RIEN,STAT,TGLOB,VISIT,WIEN,RARPT
+3 NEW ACCN,BQII,D0,DA,DIC,DK,FULLE,FULLR,ECHR,FRIL,I,J,K,LEN,LG,LIEN,LN,PRCN,TAB,VAL,VALUE,VHD
+4 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+5 SET DATA=$NAME(^TMP("BTPWEHIS",UID))
+6 KILL @DATA
+7 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+8 ;
+9 SET BQII=0
+10 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BTPWPPAT D UNWIND^%ZTER"
+11 ;
+12 SET HDR="T00040CATEGORY^T00060EVENT^D00015EVNT_DATE^T01024EXP_EVENT^D00030RESULT^T01024EXP_RESULT^"
+13 SET HDR=HDR_"T01024HIDE_RESULT^T01024INTERPRETATION^T01024HIDE_INTERPRETATION"
+14 SET @DATA@(BQII)=HDR_$CHAR(30)
+15 ;
+16 SET OCAT=$GET(OCAT,"")
SET TGLOB=$NAME(^XTMP("BTPWPRC"))
+17 ;
+18 ; If history of all events for this patient
+19 SET PRCN=""
FOR
SET PRCN=$ORDER(@TGLOB@(DFN,PRCN))
IF PRCN=""
QUIT
Begin DoDot:1
+20 IF PRCN="~"
QUIT
+21 ;
+22 ;Get internal category and filter on inputed category
+23 SET CAT=$$GET1^DIQ(90621,PRCN_",",.1,"I")
IF OCAT'=""
IF CAT'=OCAT
QUIT
+24 ;Get external Category
SET CAT=$$CAT^BTPWPDSP(PRCN)
+25 DO LEVT(PRCN,CAT)
End DoDot:1
+26 ;
DONE ;
+1 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+2 QUIT
+3 ;
LEVT(PRCN,CAT) ;EP - Get event
+1 NEW EXVDT,INTR,HINTR,HLINK
+2 SET VSDTM=""
SET PROCNM=$PIECE(^BTPW(90621,PRCN,0),U,1)
+3 SET WHREC=""
SET RARPT=""
SET LINK=""
SET ACCN=""
+4 FOR
SET VSDTM=$ORDER(@TGLOB@(DFN,PRCN,VSDTM))
IF VSDTM=""
QUIT
Begin DoDot:1
+5 SET ORD=""
+6 SET ORD=$ORDER(@TGLOB@(DFN,PRCN,VSDTM,ORD))
IF ORD=""
QUIT
Begin DoDot:2
+7 SET VISIT=""
SET QFL=1
+8 SET VISIT=$ORDER(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT))
IF VISIT=""
QUIT
Begin DoDot:3
+9 SET RIEN=""
SET STAT=""
SET RARPT=""
SET ACCN=""
+10 SET RIEN=$ORDER(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN))
IF RIEN=""
QUIT
Begin DoDot:4
+11 SET WHIEN=""
SET BREC(VSDTM)=RIEN
SET WHREC=""
+12 IF $GET(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN))=""
Begin DoDot:5
+13 SET WIEN=$ORDER(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,""))
+14 SET WHIEN=$PIECE(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,WIEN),U,1)
+15 SET REF=$PIECE(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,WIEN),U,2,3)
+16 SET RARPT=$PIECE(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,WIEN),U,4)
End DoDot:5
+17 IF $GET(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN))'=""
Begin DoDot:5
+18 SET WHIEN=$PIECE(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN),U,1)
+19 SET REF=$PIECE(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN),U,2,3)
+20 SET RARPT=$PIECE(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN),U,4)
End DoDot:5
End DoDot:4
IF 'QFL
QUIT
+21 ;
+22 ; Look for entry in Tracked file - pull interpretation
+23 SET (HINTR,INTR)=""
+24 SET FRIL=$PIECE(REF,U,2)
IF FRIL]""
SET FRIL=$ORDER(^BTPW(90621.1,"B",FRIL,""))
+25 IF DFN'=""
IF PRCN'=""
IF VISIT'=""
IF RIEN'=""
IF FRIL'=""
Begin DoDot:4
+26 NEW TIEN
+27 SET TIEN=$ORDER(^BTPWP("C",DFN,PRCN,VISIT,RIEN,FRIL,""))
+28 IF TIEN]""
SET INTR=$$INTER^BTPWPEVT(TIEN)
SET HINTR=$PIECE(INTR,$CHAR(26),2)
SET INTR=$PIECE(INTR,$CHAR(26))
End DoDot:4
+29 ;
+30 IF VISIT="~"
SET VISIT=""
+31 ; pull interpretation if WH record
+32 IF $GET(INTR)=""
IF WHIEN'=""
SET INTR=$$INTER^BTPWPEVT("",WHIEN)
SET HINTR=$PIECE(INTR,$CHAR(26),2)
SET INTR=$PIECE(INTR,$CHAR(26))
+33 SET RIEN=$GET(BREC(VSDTM))
+34 SET EXVDT=$$FMTE^BQIUL1(VSDTM)
+35 IF $PIECE(REF,U,1)=9000010.09
Begin DoDot:4
+36 IF RIEN'="~"
IF RIEN'=""
IF WHIEN=""
SET ACCN=$PIECE($GET(^AUPNVLAB(RIEN,0)),U,6)
+37 IF $EXTRACT(ACCN,1,2)="WH"
SET WHIEN=$ORDER(^BPWCD("B",$EXTRACT(ACCN,3,$LENGTH(ACCN)),""))
IF WHIEN'=""
SET ACCN=""
End DoDot:4
+38 SET FULLR=""
+39 ; If V LAB but now RIEN and WH IEN
+40 IF ACCN=""
IF WHIEN'=""
SET $PIECE(REF,U,2)="WH RECORD"
+41 ; If WH record but no result has been entered
+42 ;I WHIEN'="",$P($G(^BWPCD(WHIEN,0)),U,5)="" S WHIEN=""
+43 SET LINK=""
+44 IF WHIEN'=""
SET LINK=EXVDT_$CHAR(28)_$PIECE(REF,U,2)_$CHAR(28)_"W:"_WHIEN
+45 IF RARPT'=""
SET LINK=EXVDT_$CHAR(28)_$PIECE(REF,U,2)_$CHAR(28)_"R:"_RARPT
+46 IF WHIEN'=""
Begin DoDot:4
+47 NEW TDATA
+48 DO EN^BTPWRWHP(.TDATA,WHIEN)
+49 FOR I=1:1
IF @TDATA@(I)=$CHAR(30)
QUIT
SET FULLR=FULLR_@TDATA@(I)
End DoDot:4
+50 IF RARPT'=""
Begin DoDot:4
+51 NEW TDATA
+52 DO EN^BTPWRRAD(.TDATA,DFN,RARPT)
+53 FOR I=1:1
IF @TDATA@(I)=$CHAR(30)
QUIT
SET FULLR=FULLR_@TDATA@(I)
End DoDot:4
+54 IF ACCN'=""
Begin DoDot:4
+55 NEW RES
+56 SET RES=$PIECE($GET(^AUPNVLAB(RIEN,0)),U,4)
+57 NEW TDATA
+58 DO EN^BTPWRLAB(.TDATA,DFN,RIEN)
+59 FOR I=1:1
IF @TDATA@(I)=$CHAR(30)
QUIT
SET FULLR=FULLR_@TDATA@(I)
+60 IF RES=""
IF $PIECE($GET(^AUPNVLAB(RIEN,11)),U,9)'="R"
QUIT
+61 SET LINK=EXVDT_$CHAR(28)_$PIECE(REF,U,2)_$CHAR(28)_"L:"_RIEN
End DoDot:4
+62 SET HLINK=$PIECE(LINK,$CHAR(28),2,3)
SET LINK=$PIECE(LINK,$CHAR(28))
+63 SET FULLE="Event obtained from: "_$CHAR(13)_$CHAR(10)
Begin DoDot:4
+64 IF WHIEN'=""
SET FULLE=FULLE_"Women's Health Package"
QUIT
+65 SET FULLE=FULLE_$PIECE(^BTPW(90621.1,FRIL,0),"^",1)_" - "
+66 NEW FIL,FLD
+67 SET FIL=$PIECE(^BTPW(90621.1,FRIL,0),"^",2)
SET FLD=$PIECE(^(0),"^",3)
SET TAB=$PIECE(^(0),"^",8)
+68 SET FULLE=FULLE_$$GET1^DIQ(FIL,RIEN_",",FLD,"E")
+69 SET LIEN=$$GET1^DIQ(FIL,RIEN_",",FLD,"I")
+70 IF TAB=80!(TAB=80.1)!(TAB=81)
Begin DoDot:5
End DoDot:5
+71 IF TAB=80
SET FULLE=FULLE_" "_$$ICD9^BQIUL3(LIEN,,4)_$CHAR(13)_$CHAR(10)
QUIT
+72 IF TAB=80.1
SET FULLE=FULLE_" "_$$ICD0^BQIUL3(LIEN,,5)_$CHAR(13)_$CHAR(10)
QUIT
+73 IF TAB=81
SET FULLE=FULLE_" "_$$ICPT^BQIUL3(LIEN,"",3)
End DoDot:4
+74 SET BQII=BQII+1
SET @DATA@(BQII)=CAT_U_PROCNM_U_EXVDT_U_FULLE_U_LINK_U_FULLR_U_HLINK_U_INTR_U_HINTR_$CHAR(30)
End DoDot:3
IF 'QFL
QUIT
End DoDot:2
IF 'QFL
QUIT
End DoDot:1
+75 QUIT
