BEHOCACV ;MSC/IND/DKM - CWADF ;18-Dec-2012 10:55;PLS
;;1.1;BEH COMPONENTS;**029003,029004**;Sep 18, 2007
;=================================================================
; Return posting list for patient
LIST(DATA,DFN) ;
S DATA=$NA(^TMP("TIUPPCV",$J))
D GET(DFN)
Q
; Return allergy/adverse reaction info in report format
DETAIL(DATA,DFN) ;
N CNT,LP,LP2,RXN,SEV,X
S DATA=$$TMPGBL^CIAVMRPC,(CNT,LP)=0
D EN1^GMRAOR1(DFN,"RXN")
S @DATA@(1)=$S($G(RXN)="":"No allergy assessment.",'RXN:"No known allergies.",1:"No allergies found.")
F S LP=$O(RXN(LP)) Q:'LP D
.S X=RXN(LP),SEV=$P(X,U,2)
.D ADD($P(X,U)_" [Severity: "_$S($L(SEV):SEV,1:"Unknown")_"]")
.S X=" Signs/symptoms:",LP2=0
.F S LP2=$O(RXN(LP,"S",LP2)) Q:'LP2 D ADD($P(RXN(LP,"S",LP2),";"),.X)
Q
; RPC to return CWAD flags
CWAD(DATA,DFN) ;
S DATA=$$CWADX(DFN)
Q
; Return CWAD flags
CWADX(DFN) ;
N ACRN,CTR,LST
D GET(DFN)
S LST="cwadf",CTR=0
F S CTR=$O(^TMP("TIUPPCV",$J,CTR)) Q:(CTR'>0)!(LST?4U) S ACRN=$P($G(^(CTR)),U,2) D:$L(ACRN)=1
.S:"CWADF"[ACRN LST=$TR(LST,$C($A(ACRN)+32),ACRN)
K ^TMP("TIUPPCV",$J)
Q $TR(LST,"cwadf")
; Add to output array
ADD(TXT,LBL,IDT) ;
S CNT=CNT+1,@DATA@(CNT)=$S($D(LBL):$$LJ^XLFSTR(LBL,$G(IDT,20)),1:"")_$G(TXT),LBL=""
Q
; Get CWAD and PRF flags
GET(DFN) N PRF,CNT,RES
K ^TMP("TIUPPCV",$J)
Q:'DFN
D ENCOVER^TIUPP3(DFN)
S RES=$$GETACT^DGPFAPI(DFN,"PRF")
S PRF=0,CNT=$O(^TMP("TIUPPCV",$J,""),-1)
F S PRF=$O(PRF(PRF)) Q:'PRF D
.N X,Y
.S Y=$O(^DGPF(26.13,"C",DFN,$P(PRF(PRF,"FLAG"),U),0))_"^F"
.F X="2^FLAG","2^FLAGTYPE","1^ASSIGNDT" S Y=Y_U_$P($G(PRF(PRF,$P(X,U,2))),U,+X)
.S CNT=CNT+1,^TMP("TIUPPCV",$J,CNT)=Y_U_PRF
Q
; Get patient record flag detail
PRF(DATA,DFN,IEN) ;
N CNT
S DATA=$$TMPGBL^CIAVMRPC,CNT=0
I '$G(IEN) D
.S IEN=0
.F S IEN=$O(^DGPF(26.13,"B",DFN,IEN)) Q:'IEN D
..Q:'$P($G(^DGPF(26.13,IEN,0)),U,3)
..D:CNT ADD($$REPEAT^XLFSTR("_",80)),ADD("")
..D PRFX(DFN,IEN)
E D PRFX(DFN,IEN)
Q
; Get patient record detail for a single entry
PRFX(DFN,IEN) ;
N PRF,CTL
I $$GETASGN^DGPFAA(IEN,.PRF),$$GETHIST^DGPFAAH($$GETFIRST^DGPFAAH(IEN),.PRF),$$GETFLAG^DGPFUT1($P(PRF("FLAG"),U),.PRF) D
.Q:+$G(PRF("DFN"))'=DFN
.D:'CNT ADD($$GET1^DIQ(2,DFN,.01),"Patient:",25),ADD("")
.F CTL="FLAG^Flag Name","TYPE^Flag Type","STATUS^Assignment Status","ASSIGNDT^Initial Assigned Date","APPRVBY^Approved by","REVIEWDT^Next Review Date","OWNER^Owner Site","ORIGSITE^Originating Site" D
..D ADD($P(PRF($P(CTL,U)),U,2),$P(CTL,U,2)_":",25)
.I $D(PRF("NARR")) D
..D ADD(""),ADD("Assignment Narratives:"),ADD("")
..M @DATA@(CNT)=PRF("NARR")
..S CNT=CNT+1
Q
BEHOCACV ;MSC/IND/DKM - CWADF ;18-Dec-2012 10:55;PLS
+1 ;;1.1;BEH COMPONENTS;**029003,029004**;Sep 18, 2007
+2 ;=================================================================
+3 ; Return posting list for patient
LIST(DATA,DFN) ;
+1 SET DATA=$NAME(^TMP("TIUPPCV",$JOB))
+2 DO GET(DFN)
+3 QUIT
+4 ; Return allergy/adverse reaction info in report format
DETAIL(DATA,DFN) ;
+1 NEW CNT,LP,LP2,RXN,SEV,X
+2 SET DATA=$$TMPGBL^CIAVMRPC
SET (CNT,LP)=0
+3 DO EN1^GMRAOR1(DFN,"RXN")
+4 SET @DATA@(1)=$SELECT($GET(RXN)="":"No allergy assessment.",'RXN:"No known allergies.",1:"No allergies found.")
+5 FOR
SET LP=$ORDER(RXN(LP))
IF 'LP
QUIT
Begin DoDot:1
+6 SET X=RXN(LP)
SET SEV=$PIECE(X,U,2)
+7 DO ADD($PIECE(X,U)_" [Severity: "_$SELECT($LENGTH(SEV):SEV,1:"Unknown")_"]")
+8 SET X=" Signs/symptoms:"
SET LP2=0
+9 FOR
SET LP2=$ORDER(RXN(LP,"S",LP2))
IF 'LP2
QUIT
DO ADD($PIECE(RXN(LP,"S",LP2),";"),.X)
End DoDot:1
+10 QUIT
+11 ; RPC to return CWAD flags
CWAD(DATA,DFN) ;
+1 SET DATA=$$CWADX(DFN)
+2 QUIT
+3 ; Return CWAD flags
CWADX(DFN) ;
+1 NEW ACRN,CTR,LST
+2 DO GET(DFN)
+3 SET LST="cwadf"
SET CTR=0
+4 FOR
SET CTR=$ORDER(^TMP("TIUPPCV",$JOB,CTR))
IF (CTR'>0)!(LST?4U)
QUIT
SET ACRN=$PIECE($GET(^(CTR)),U,2)
IF $LENGTH(ACRN)=1
Begin DoDot:1
+5 IF "CWADF"[ACRN
SET LST=$TRANSLATE(LST,$CHAR($ASCII(ACRN)+32),ACRN)
End DoDot:1
+6 KILL ^TMP("TIUPPCV",$JOB)
+7 QUIT $TRANSLATE(LST,"cwadf")
+8 ; Add to output array
ADD(TXT,LBL,IDT) ;
+1 SET CNT=CNT+1
SET @DATA@(CNT)=$SELECT($DATA(LBL):$$LJ^XLFSTR(LBL,$GET">GET(IDT,20)),1:"")_$GET">GET(TXT)
SET LBL=""
+2 QUIT
+3 ; Get CWAD and PRF flags
GET(DFN) NEW PRF,CNT,RES
+1 KILL ^TMP("TIUPPCV",$JOB)
+2 IF 'DFN
QUIT
+3 DO ENCOVER^TIUPP3(DFN)
+4 SET RES=$$GETACT^DGPFAPI(DFN,"PRF")
+5 SET PRF=0
SET CNT=$ORDER(^TMP("TIUPPCV",$JOB,""),-1)
+6 FOR
SET PRF=$ORDER(PRF(PRF))
IF 'PRF
QUIT
Begin DoDot:1
+7 NEW X,Y
+8 SET Y=$ORDER(^DGPF(26.13,"C",DFN,$PIECE(PRF(PRF,"FLAG"),U),0))_"^F"
+9 FOR X="2^FLAG","2^FLAGTYPE","1^ASSIGNDT"
SET Y=Y_U_$PIECE($GET(PRF(PRF,$PIECE(X,U,2))),U,+X)
+10 SET CNT=CNT+1
SET ^TMP("TIUPPCV",$JOB,CNT)=Y_U_PRF
End DoDot:1
+11 QUIT
+12 ; Get patient record flag detail
PRF(DATA,DFN,IEN) ;
+1 NEW CNT
+2 SET DATA=$$TMPGBL^CIAVMRPC
SET CNT=0
+3 IF '$GET(IEN)
Begin DoDot:1
+4 SET IEN=0
+5 FOR
SET IEN=$ORDER(^DGPF(26.13,"B",DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+6 IF '$PIECE($GET(^DGPF(26.13,IEN,0)),U,3)
QUIT
+7 IF CNT
DO ADD($$REPEAT^XLFSTR("_",80))
DO ADD("")
+8 DO PRFX(DFN,IEN)
End DoDot:2
End DoDot:1
+9 IF '$TEST
DO PRFX(DFN,IEN)
+10 QUIT
+11 ; Get patient record detail for a single entry
PRFX(DFN,IEN) ;
+1 NEW PRF,CTL
+2 IF $$GETASGN^DGPFAA(IEN,.PRF)
IF $$GETHIST^DGPFAAH($$GETFIRST^DGPFAAH(IEN),.PRF)
IF $$GETFLAG^DGPFUT1($PIECE(PRF("FLAG"),U),.PRF)
Begin DoDot:1
+3 IF +$GET(PRF("DFN"))'=DFN
QUIT
+4 IF 'CNT
DO ADD($$GET1^DIQ(2,DFN,.01),"Patient:",25)
DO ADD("")
+5 FOR CTL="FLAG^Flag Name","TYPE^Flag Type","STATUS^Assignment Status","ASSIGNDT^Initial Assigned Date","APPRVBY^Approved by","REVIEWDT^Next Review Date","OWNER^Owner Site","ORIGSITE^Originating Site"
Begin DoDot:2
+6 DO ADD($PIECE(PRF($PIECE(CTL,U)),U,2),$PIECE(CTL,U,2)_":",25)
End DoDot:2
+7 IF $DATA(PRF("NARR"))
Begin DoDot:2
+8 DO ADD("")
DO ADD("Assignment Narratives:")
DO ADD("")
+9 MERGE @DATA@(CNT)=PRF("NARR")
+10 SET CNT=CNT+1
End DoDot:2
End DoDot:1
+11 QUIT
