BHSWPROF.m

BHSWPROF ;IHS/CIA/MGH - Lookup and display of women's health profile ;17-Mar-2006 10:36;MGH

 ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006

 ;==================================================================

 ;;Routine is a re-write of the IHS routine to display the women's

 ;health profile in a VA health summar format

 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *

 ;;  CALL ED BY OPTION: "BW PATIENT PROFILE" TO DISPLAY PROFILE.

 ;;  PATCHED AT LINELABEL PROFCALL.  IHS/ANMC/MWR 11/20/96

 ;

EP(BWDFN,BWD,BWEXT) ;PEP called without user interaction to display profile

 ;IHS/CMI/LAB - patch 6 added this subroutine this is

 ;called from the health summary.

 ;---> PATCHED: EARLIER METHODS FOR OTHER PACKAGES TO PRODUCE A

 ;---> WOMEN'S HEALTH PROFILE WERE TO CUMBERSOME AND ERROR PRONE.

 ;---> USED TO CALL A PATIENT PROFILE (DISPLAY ONLY) WITH PATIENT

 ;---> ALREADY SELECTED.  DFN PASSED AS FIRST PARAMETER.

 N BWERRORS,BWUSER

 N BWNAME,BWNAMAGE,BWCHRT,BWCMGR,BWCNEED,BWPAPRG,BWBNEED,BWEDC,BWERRORS

 Q:'$G(BWDFN)

 Q:$G(BWD)=""  ;did not pass brief/detailed

 Q:'$D(^BWP(BWDFN,0))

EP1 ;

 S BWERRORS=1

 D SORT^BWPROF2

 D COPYGBL

 Q

HEADER ;Put the header data into ^TMP("BHS",$J,1,COUNT)

 N FIRST

 S ^TMP("BHS",$J,1,1)=$$PNLAB^BWUTL5(DUZ(2))_"   "_BWCHRT

 S FIRST="Case Manager: "_BWCMGR

 S ^TMP("BHS",$J,1,2)=FIRST_"^Facility: "_$E($$INSTTX^BWUTL6(DUZ(2)),1,19)

 S FIRST="Cx Tx Need  : "_BWCNEED

 S ^TMP("BHS",$J,1,3)=FIRST_"^Inact Date: "_$$SLDT2^BWUTL5($$INACT^BWUTL1(BWDFN))

 S FIRST="PAP Regimen : "_BWPAPRG

 N X

 S X=$P(^BWP(BWDFN,0),U,29)

 S ^TMP("BHS",$J,1,4)=FIRST_"^Income Elig: "_$S(X=1:"YES",X=2:"NO",X=3:"REFUSED",1:"NOT DETERMINED")

 S FIRST="Br Tx Need  : "_BWBNEED

 N X

 S X=$P(^BWP(BWDFN,0),U,30)

 S ^TMP("BHS",$J,1,5)=FIRST_"^Income Date: "_$$SLDT2^BWUTL5(X)

 Q

EXIT ;EP

 D KILLALL^BWUTL8

 Q

COPYGBL ;EP

 ;---> COPY ^TMP("BW",$J,1 TO ^TMP("BHS",$J,2 TO MAKE IT FLAT.

 N I,M,N,P,Q,COUNT

 ;Enter the patient array first

 D HEADER

 S N=0,I=0

 F  S N=$O(^TMP("BW",$J,1,N)) Q:N=""  D

 .S M=0

 .F  S M=$O(^TMP("BW",$J,1,N,M)) Q:M=""  D

 ..S P=0

 ..F  S P=$O(^TMP("BW",$J,1,N,M,P)) Q:P=""  D

 ...S Q=0

 ...F  S Q=$O(^TMP("BW",$J,1,N,M,P,Q)) Q:Q=""  D

 ....S I=I+1,^TMP("BHS",$J,2,I)=^TMP("BW",$J,1,N,M,P,Q)

 Q

BHSWPROF  ;IHS/CIA/MGH - Lookup and display of women's health profile ;17-Mar-2006 10:36;MGH

 +1       ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006

 +2       ;==================================================================

 +3       ;;Routine is a re-write of the IHS routine to display the women's

 +4       ;health profile in a VA health summar format

 +5       ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *

 +6       ;;  CALL ED BY OPTION: "BW PATIENT PROFILE" TO DISPLAY PROFILE.

 +7       ;;  PATCHED AT LINELABEL PROFCALL.  IHS/ANMC/MWR 11/20/96

 +8       ;

EP(BWDFN,BWD,BWEXT) ;PEP called without user interaction to display profile

 +1       ;IHS/CMI/LAB - patch 6 added this subroutine this is

 +2       ;called from the health summary.

 +3       ;---> PATCHED: EARLIER METHODS FOR OTHER PACKAGES TO PRODUCE A

 +4       ;---> WOMEN'S HEALTH PROFILE WERE TO CUMBERSOME AND ERROR PRONE.

 +5       ;---> USED TO CALL A PATIENT PROFILE (DISPLAY ONLY) WITH PATIENT

 +6       ;---> ALREADY SELECTED.  DFN PASSED AS FIRST PARAMETER.

 +7        NEW BWERRORS,BWUSER

 +8        NEW BWNAME,BWNAMAGE,BWCHRT,BWCMGR,BWCNEED,BWPAPRG,BWBNEED,BWEDC,BWERRORS

 +9        IF '$GET(BWDFN)

               QUIT 

 +10      ;did not pass brief/detailed

           IF $GET(BWD)=""

               QUIT 

 +11       IF '$DATA(^BWP(BWDFN,0))

               QUIT 

EP1       ;

 +1        SET BWERRORS=1

 +2        DO SORT^BWPROF2

 +3        DO COPYGBL

 +4        QUIT 

HEADER    ;Put the header data into ^TMP("BHS",$J,1,COUNT)

 +1        NEW FIRST

 +2        SET ^TMP("BHS",$JOB,1,1)=$$PNLAB^BWUTL5(DUZ(2))_"   "_BWCHRT

 +3        SET FIRST="Case Manager: "_BWCMGR

 +4        SET ^TMP("BHS",$JOB,1,2)=FIRST_"^Facility: "_$EXTRACT($$INSTTX^BWUTL6(DUZ(2)),1,19)

 +5        SET FIRST="Cx Tx Need  : "_BWCNEED

 +6        SET ^TMP("BHS",$JOB,1,3)=FIRST_"^Inact Date: "_$$SLDT2^BWUTL5($$INACT^BWUTL1(BWDFN))

 +7        SET FIRST="PAP Regimen : "_BWPAPRG

 +8        NEW X

 +9        SET X=$PIECE(^BWP(BWDFN,0),U,29)

 +10       SET ^TMP("BHS",$JOB,1,4)=FIRST_"^Income Elig: "_$SELECT(X=1:"YES",X=2:"NO",X=3:"REFUSED",1:"NOT DETERMINED")

 +11       SET FIRST="Br Tx Need  : "_BWBNEED

 +12       NEW X

 +13       SET X=$PIECE(^BWP(BWDFN,0),U,30)

 +14       SET ^TMP("BHS",$JOB,1,5)=FIRST_"^Income Date: "_$$SLDT2^BWUTL5(X)

 +15       QUIT 

EXIT      ;EP

 +1        DO KILLALL^BWUTL8

 +2        QUIT 

COPYGBL   ;EP

 +1       ;---> COPY ^TMP("BW",$J,1 TO ^TMP("BHS",$J,2 TO MAKE IT FLAT.

 +2        NEW I,M,N,P,Q,COUNT

 +3       ;Enter the patient array first

 +4        DO HEADER

 +5        SET N=0

           SET I=0

 +6        FOR 

               SET N=$ORDER(^TMP("BW",$JOB,1,N))

               IF N=""

                   QUIT 

               Begin DoDot:1

 +7                SET M=0

 +8                FOR 

                       SET M=$ORDER(^TMP("BW",$JOB,1,N,M))

                       IF M=""

                           QUIT 

                       Begin DoDot:2

 +9                        SET P=0

 +10                       FOR 

                               SET P=$ORDER(^TMP("BW",$JOB,1,N,M,P))

                               IF P=""

                                   QUIT 

                               Begin DoDot:3

 +11                               SET Q=0

 +12                               FOR 

                                       SET Q=$ORDER(^TMP("BW",$JOB,1,N,M,P,Q))

                                       IF Q=""

                                           QUIT 

                                       Begin DoDot:4

 +13                                       SET I=I+1

                                           SET ^TMP("BHS",$JOB,2,I)=^TMP("BW",$JOB,1,N,M,P,Q)

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +14       QUIT