BEHOCACV.m

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