Routine: BPCBWDSP

BPCBWDSP ; IHS/OIT/MJL - DISPLAY PATIENT PROFILE ; [ 12/31/2007  10:16 AM ]

 ;;1.5;BPC;**4**;FEB 16, 2005

 ;;MODIFIED FOR PATIENT CHART  FJE 6/19/00

 ;;* 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

 ;---> *NOTE: TO ASK DATE RANGE, UNCOMMENT ALL LINES WITH "XDATES",

 ;--->        AND IN HEADER2^BWUTL7.

 ;---> VARIABLES:

 ;---> BWDFN: DFN OF SELECTED PATIENT

 ;---> DATES: BWBEGDT=BEGINNING DATE, BWENDDT=ENDING DATE

 ;---> USE NODES 1 & 2 IN ^TMP GLOBAL.

GETBWDSP(BGUARRAY,BPCPIEN) ;;EP REMOTE PROC: BPC GETBWDATA

EN ;

 S JOB=$J,BPCGUI=1,XWBWRAP=1

 S BGUARRAY="^XTMP(""BPCBW"","_$J_")"

 I BPCPIEN="" S ^XTMP("BPCBW",JOB,1)=-1,^XTMP("BPCBW",JOB,2)="PATIENT IEN NOT SENT!" Q

 I '$D(^BWP(BPCPIEN,0)) S ^XTMP("BPCBW",JOB,1)=-1,^XTMP("BPCBW",JOB,2)="PATIENT IS NOT DEFINED IN WOMEN'S HEALTH!" Q

 S X="WOMEN'S HEALTH",DIC="^DIC(9.4,",DIC(0)="XMZ" D ^DIC I +Y<1 S ^XTMP("BPCBW",JOB,1)=-1,^XTMP("BPCBW",JOB,2)="WOMEN'S HEALTH NOT INSTALLED!" Q

 I +$G(^DIC(9.4,+Y,"VERSION"))<2 S ^XTMP("BPCBW",JOB,1)=-1,^XTMP("BPCBW",JOB,2)="WOMEN'S HEALTH VERSION INCORRECT!" Q

 S BWDFN=BPCPIEN

 S BWD=1

 K ^XTMP("BPCBW",JOB)

 S ^XTMP("BPCBWRUN",JOB)=""

 S ZTRTN="TSK^BPCBWDSP",ZTIO="",ZTDESC="BPC BW REPORT",ZTSAVE("BWDFN")="",ZTSAVE("BWD")="",ZTSAVE("JOB")="",ZTDTH=$H D ^%ZTLOAD

 F I=1:1:60 Q:$G(^XTMP("BPCBWRUN",$J))="DONE"  H 1

 I $G(^XTMP("BPCBWRUN",JOB))'="DONE" S ^XTMP("BPCBW",JOB,1)=-1,^(2)="WOMEN'S HEALTH SUMMARY RUN FAILURE-CHECK SYSTEM TASKMAN" Q

 S X=0,BPCCTR=0 F  S X=$O(^XTMP("BPCBW",JOB,X)) Q:+X=0  S BPCCTR=BPCCTR+1

 S ^XTMP("BPCBW",JOB,.5)=BPCCTR+1

TSK ;

 D ^XBKSET

 S ^XTMP("BPCBWRUN",JOB)="START"

 ;S APCHSPAT=1,APCHSTYP=7 FOR TESTING

 D GUIR^XBLM("STRT^BPCBWDSP","^XTMP(""BPCBW"",JOB)")

 S ^XTMP("BPCBWRUN",JOB)="DONE"

STRT D SETVARS^BWUTL5

 S:'$D(BWERRORS) BWERRORS=1

 ;F  D RUN Q:BWPOP

 ;D EXIT

;Q

RUN ;EP

 D TITLE^BWUTL5("PATIENT PROFILE")

 ;D PATIENT Q:BWPOP

 ;D DATES  Q:BWPOP

 D BRIEF   Q:BWPOP

 ;D DEVICE  Q:BWPOP

 D SORT^BWPROF2

 D COPYGBL

;Q

 D ^BWPROF1 S BWPOP=0

 K BWD,BWSUBH

EXIT ;EP

 D KILLALL^BWUTL8

PATIENT ;EP

 ;---> SELECT PATIENT (RETURN BWDFN).

 ;W !!,"   Select the patient whose Profile you wish to display."

 ;D PATLKUP^BWUTL8(.Y) S:Y<0 BWPOP=1

 ;---> USE NEXT LINE IF I WANT TO ADD CAPABILITY OF ADDING NEW PATIENT.

 ;D PATLKUP^BWUTL8(.Y,$S($G(BWPUSER):"",1:"ADD")) S:Y<0 BWPOP=1

 ;S BWDFN=+Y

 ;S BWDFN=6878

DATES ;EP

 ;---> ASK DATE RANGE.  RETURN DATES IN BWBEGDT AND BWENDDT.

 ;---> IF LOOKING AT ONLY ONE PATIENT, SET DEFAULT BEGIN DATE=T-5YEARS.

 ;S BWBEGDT=2500101,BWENDDT=DT     ;---> XDATES-CAN USE THIS INSTEAD.

 ;S BWBEGDF="T-60M",BWENDDF="T"    ;---> XDATES

 ;D ASKDATES^BWUTL3(.BWBEGDT,.BWENDDT,.BWPOP,"T-365","T")  ;---> XDATES

BRIEF ;EP

 ;---> BRIEF OR DETAILED LISTING OF PROCEDURES (BRIEF DOES NOT LIST

 ;---> NOTIFICATIONS AND PROVIDERS).

 ;N DIR,DIRUT,Y

 ;W !!?3,"List Patient Profile in BRIEF or DETAILED format?"

 ;S DIR("A")="   Select BRIEF or DETAILED: ",DIR("B")="BRIEF"

 ;S DIR(0)="SAM^b:BRIEF;d:DETAILED" D HELP1

 ;D ^DIR

 ;I Y=-1!($D(DIRUT)) S BWPOP=1 Q

 ;---> IF ALL DETAILED, S BWD=1; FOR BRIEF BWD=0

 ;S BWD=$S(Y="d":1,1:0)

 S BWD=1

DEVICE ;EP

 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.

 S ZTRTN="DEQUEUE^BWPROF"

 F BWSV="D","DFN","BEGDT","ENDDT","ERRORS" D

 .I $D(@("BW"_BWSV)) S ZTSAVE("BW"_BWSV)=""

 D ZIS^BWUTL2(.BWPOP,1,"HOME")

COPYGBL ;EP

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

 N I,M,N,P,Q

 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("BW",$J,2,I)=^TMP("BW",$J,1,N,M,P,Q)

DEQUEUE ;EP

 ;---> EP FOR TASKMAN QUEUE OF PRINTOUT.

 D SETVARS^BWUTL5,SORT^BWPROF2,COPYGBL,^BWPROF1,EXIT

HELP1 ;EP

 ;;Enter "D" for a "Detailed" listing of the patient's Procedures,

 ;;Notifications, PAP Regimen and Pregnancy changes.

 ;;Enter "B" for a "Brief" listing of the patient's Procedures only.

 S BWTAB=5,BWLINL="HELP1" D HELPTX

HELPTX ;EP

 ;---> CREATES DIR ARRAY FOR DIR.  REQUIRED VARIABLES: BWTAB,BWLINL.

 N I,T,X S T="" F I=1:1:BWTAB S T=T_" "

 F I=1:1 S X=$T(@BWLINL+I) Q:X'[";;"  S DIR("?",I)=T_$P(X,";;",2)

 S DIR("?")=DIR("?",I-1) K DIR("?",I-1)

USER ;EP

 ;---> CALLED BY OPTION: "BW PATIENT PROFILE USER"

 ;---> FOR USER TO VIEW PROFILE AND PRINT PROCEDURES, BUT NO EDIT.

 S BWPUSER=1

 ;D BWPROF K BWPUSER

PROFCALL(BWDFN) ;EP

 ;---> 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.

 ;---> THIS ENTIRE CALL HAS BEEN ADDED AS A PATCH. IHS/ANMC/MWR 11/20/96

 ;I '$G(BWDFN) D  Q

 ;.W !?5,"Patient DFN was not passed.  Please contact your site manager."

 ;.D DIRZ^BWUTL3

 ;I '$D(^BWP(BWDFN,0)) D  Q

 ;.W !?5,"This patient is not currently in the Women's Health Database."

 ;.D DIRZ^BWUTL3

 ;N (BWDFN)

 ;D SETVARS^BWUTL5 S BWERRORS=1,BWPUSER=1

 ;D BRIEF  Q:BWPOP

 ;D DEVICE Q:BWPOP

 ;D SORT^BWPROF2

 ;D COPYGBL

 ;D ^BWPROF1

ERRORS ;EP

 ;---> CALLED BY OPTION: "BW PATIENT PROFILE W/ERRORS"

 ;---> ENTER HERE TO INCLUDE ERRONEOUS ENTRIES.

 ;S BWERRORS=0 G BWPROF

BPCBWDSP  ; IHS/OIT/MJL - DISPLAY PATIENT PROFILE ; [ 12/31/2007  10:16 AM ]

 +1       ;;1.5;BPC;**4**;FEB 16, 2005

 +2       ;;MODIFIED FOR PATIENT CHART  FJE 6/19/00

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

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

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

 +6       ;

 +7       ;---> *NOTE: TO ASK DATE RANGE, UNCOMMENT ALL LINES WITH "XDATES",

 +8       ;--->        AND IN HEADER2^BWUTL7.

 +9       ;

 +10      ;---> VARIABLES:

 +11      ;---> BWDFN: DFN OF SELECTED PATIENT

 +12      ;---> DATES: BWBEGDT=BEGINNING DATE, BWENDDT=ENDING DATE

 +13      ;---> USE NODES 1 & 2 IN ^TMP GLOBAL.

 +14      ;

 +15      ;

GETBWDSP(BGUARRAY,BPCPIEN) ;;EP REMOTE PROC: BPC GETBWDATA

 +1       ;

EN        ;

 +1        SET JOB=$JOB

           SET BPCGUI=1

           SET XWBWRAP=1

 +2        SET BGUARRAY="^XTMP(""BPCBW"","_$JOB_")"

 +3        IF BPCPIEN=""

               SET ^XTMP("BPCBW",JOB,1)=-1

               SET ^XTMP("BPCBW",JOB,2)="PATIENT IEN NOT SENT!"

               QUIT

 +4        IF '$DATA(^BWP(BPCPIEN,0))

               SET ^XTMP("BPCBW",JOB,1)=-1

               SET ^XTMP("BPCBW",JOB,2)="PATIENT IS NOT DEFINED IN WOMEN'S HEALTH!"

               QUIT

 +5        SET X="WOMEN'S HEALTH"

           SET DIC="^DIC(9.4,"

           SET DIC(0)="XMZ"

           DO ^DIC

           IF +Y<1

               SET ^XTMP("BPCBW",JOB,1)=-1

               SET ^XTMP("BPCBW",JOB,2)="WOMEN'S HEALTH NOT INSTALLED!"

               QUIT

 +6        IF +$GET(^DIC(9.4,+Y,"VERSION"))<2

               SET ^XTMP("BPCBW",JOB,1)=-1

               SET ^XTMP("BPCBW",JOB,2)="WOMEN'S HEALTH VERSION INCORRECT!"

               QUIT

 +7        SET BWDFN=BPCPIEN

 +8        SET BWD=1

 +9        KILL ^XTMP("BPCBW",JOB)

 +10       SET ^XTMP("BPCBWRUN",JOB)=""

 +11       SET ZTRTN="TSK^BPCBWDSP"

           SET ZTIO=""

           SET ZTDESC="BPC BW REPORT"

           SET ZTSAVE("BWDFN")=""

           SET ZTSAVE("BWD")=""

           SET ZTSAVE("JOB")=""

           SET ZTDTH=$HOROLOG

           DO ^%ZTLOAD

 +12       FOR I=1:1:60

               IF $GET(^XTMP("BPCBWRUN",$JOB))="DONE"

                   QUIT

               HANG 1

 +13       IF $GET(^XTMP("BPCBWRUN",JOB))'="DONE"

               SET ^XTMP("BPCBW",JOB,1)=-1

               SET ^(2)="WOMEN'S HEALTH SUMMARY RUN FAILURE-CHECK SYSTEM TASKMAN"

               QUIT

 +14       SET X=0

           SET BPCCTR=0

FOR

               SET X=$ORDER(^XTMP("BPCBW",JOB,X))

               IF +X=0

                   QUIT

               SET BPCCTR=BPCCTR+1

 +15       SET ^XTMP("BPCBW",JOB,.5)=BPCCTR+1

 +16       QUIT

TSK       ;

 +1        DO ^XBKSET

 +2        SET ^XTMP("BPCBWRUN",JOB)="START"

 +3       ;S APCHSPAT=1,APCHSTYP=7 FOR TESTING

 +4        DO GUIR^XBLM("STRT^BPCBWDSP","^XTMP(""BPCBW"",JOB)")

 +5        SET ^XTMP("BPCBWRUN",JOB)="DONE"

 +6        QUIT

STRT       DO SETVARS^BWUTL5

 +1        IF '$DATA(BWERRORS)

               SET BWERRORS=1

 +2       ;F  D RUN Q:BWPOP

 +3       ;D EXIT

 +4       ;Q

 +5       ;

RUN       ;EP

 +1        DO TITLE^BWUTL5("PATIENT PROFILE")

 +2       ;D PATIENT Q:BWPOP

 +3       ;D DATES  Q:BWPOP

 +4        DO BRIEF

           IF BWPOP

               QUIT

 +5       ;D DEVICE  Q:BWPOP

 +6        DO SORT^BWPROF2

 +7        DO COPYGBL

 +8       ;Q

 +9        DO ^BWPROF1

           SET BWPOP=0

 +10       KILL BWD,BWSUBH

 +11       QUIT

 +12      ;

EXIT      ;EP

 +1        DO KILLALL^BWUTL8

 +2        QUIT

 +3       ;

 +4       ;

PATIENT   ;EP

 +1       ;---> SELECT PATIENT (RETURN BWDFN).

 +2       ;W !!,"   Select the patient whose Profile you wish to display."

 +3       ;D PATLKUP^BWUTL8(.Y) S:Y<0 BWPOP=1

 +4       ;---> USE NEXT LINE IF I WANT TO ADD CAPABILITY OF ADDING NEW PATIENT.

 +5       ;D PATLKUP^BWUTL8(.Y,$S($G(BWPUSER):"",1:"ADD")) S:Y<0 BWPOP=1

 +6       ;S BWDFN=+Y

 +7       ;S BWDFN=6878

 +8        QUIT

 +9       ;

DATES     ;EP

 +1       ;---> ASK DATE RANGE.  RETURN DATES IN BWBEGDT AND BWENDDT.

 +2       ;---> IF LOOKING AT ONLY ONE PATIENT, SET DEFAULT BEGIN DATE=T-5YEARS.

 +3       ;S BWBEGDT=2500101,BWENDDT=DT     ;---> XDATES-CAN USE THIS INSTEAD.

 +4       ;S BWBEGDF="T-60M",BWENDDF="T"    ;---> XDATES

 +5       ;D ASKDATES^BWUTL3(.BWBEGDT,.BWENDDT,.BWPOP,"T-365","T")  ;---> XDATES

 +6        QUIT

 +7       ;

BRIEF     ;EP

 +1       ;---> BRIEF OR DETAILED LISTING OF PROCEDURES (BRIEF DOES NOT LIST

 +2       ;---> NOTIFICATIONS AND PROVIDERS).

 +3       ;N DIR,DIRUT,Y

 +4       ;W !!?3,"List Patient Profile in BRIEF or DETAILED format?"

 +5       ;S DIR("A")="   Select BRIEF or DETAILED: ",DIR("B")="BRIEF"

 +6       ;S DIR(0)="SAM^b:BRIEF;d:DETAILED" D HELP1

 +7       ;D ^DIR

 +8       ;I Y=-1!($D(DIRUT)) S BWPOP=1 Q

 +9       ;---> IF ALL DETAILED, S BWD=1; FOR BRIEF BWD=0

 +10      ;S BWD=$S(Y="d":1,1:0)

 +11       SET BWD=1

 +12       QUIT

 +13      ;

DEVICE    ;EP

 +1       ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.

 +2        SET ZTRTN="DEQUEUE^BWPROF"

 +3        FOR BWSV="D","DFN","BEGDT","ENDDT","ERRORS"

               Begin DoDot:1

 +4                IF $DATA(@("BW"_BWSV))

                       SET ZTSAVE("BW"_BWSV)=""

               End DoDot:1

 +5        DO ZIS^BWUTL2(.BWPOP,1,"HOME")

 +6        QUIT

 +7       ;

COPYGBL   ;EP

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

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

 +3        SET N=0

           SET I=0

 +4        FOR

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

               IF N=""

                   QUIT

               Begin DoDot:1

 +5                SET M=0

 +6                FOR

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

                       IF M=""

                           QUIT

                       Begin DoDot:2

 +7                        SET P=0

 +8                        FOR

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

                               IF P=""

                                   QUIT

                               Begin DoDot:3

 +9                                SET Q=0

 +10                               FOR

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

                                       IF Q=""

                                           QUIT

                                       Begin DoDot:4

 +11                                       SET I=I+1

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

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +12       QUIT

 +13      ;

 +14      ;

DEQUEUE   ;EP

 +1       ;---> EP FOR TASKMAN QUEUE OF PRINTOUT.

 +2        DO SETVARS^BWUTL5

           DO SORT^BWPROF2

           DO COPYGBL

           DO ^BWPROF1

           DO EXIT

 +3        QUIT

 +4       ;

HELP1     ;EP

 +1       ;;Enter "D" for a "Detailed" listing of the patient's Procedures,

 +2       ;;Notifications, PAP Regimen and Pregnancy changes.

 +3       ;;Enter "B" for a "Brief" listing of the patient's Procedures only.

 +4        SET BWTAB=5

           SET BWLINL="HELP1"

           DO HELPTX

 +5        QUIT

 +6       ;

HELPTX    ;EP

 +1       ;---> CREATES DIR ARRAY FOR DIR.  REQUIRED VARIABLES: BWTAB,BWLINL.

 +2        NEW I,T,X

           SET T=""

           FOR I=1:1:BWTAB

               SET T=T_" "

 +3        FOR I=1:1

               SET X=$TEXT(@BWLINL+I)

               IF X'[";;"

                   QUIT

               SET DIR("?",I)=T_$PIECE(X,";;",2)

 +4        SET DIR("?")=DIR("?",I-1)

           KILL DIR("?",I-1)

 +5        QUIT

 +6       ;

 +7       ;

USER      ;EP

 +1       ;---> CALLED BY OPTION: "BW PATIENT PROFILE USER"

 +2       ;---> FOR USER TO VIEW PROFILE AND PRINT PROCEDURES, BUT NO EDIT.

 +3        SET BWPUSER=1

 +4       ;D BWPROF K BWPUSER

 +5        QUIT

 +6       ;

PROFCALL(BWDFN) ;EP

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

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

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

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

 +5       ;---> THIS ENTIRE CALL HAS BEEN ADDED AS A PATCH. IHS/ANMC/MWR 11/20/96

 +6       ;I '$G(BWDFN) D  Q

 +7       ;.W !?5,"Patient DFN was not passed.  Please contact your site manager."

 +8       ;.D DIRZ^BWUTL3

 +9       ;I '$D(^BWP(BWDFN,0)) D  Q

 +10      ;.W !?5,"This patient is not currently in the Women's Health Database."

 +11      ;.D DIRZ^BWUTL3

 +12      ;N (BWDFN)

 +13      ;D SETVARS^BWUTL5 S BWERRORS=1,BWPUSER=1

 +14      ;D BRIEF  Q:BWPOP

 +15      ;D DEVICE Q:BWPOP

 +16      ;D SORT^BWPROF2

 +17      ;D COPYGBL

 +18      ;D ^BWPROF1

 +19       QUIT

 +20      ;

ERRORS    ;EP

 +1       ;---> CALLED BY OPTION: "BW PATIENT PROFILE W/ERRORS"

 +2       ;---> ENTER HERE TO INCLUDE ERRONEOUS ENTRIES.

 +3       ;S BWERRORS=0 G BWPROF

 +4        QUIT

BPCBWDSP.m