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
Q
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"
Q
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
Q
;
EXIT ;EP
D KILLALL^BWUTL8
Q
;
;
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
Q
;
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
Q
;
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
Q
;
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")
Q
;
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)
Q
;
;
DEQUEUE ;EP
;---> EP FOR TASKMAN QUEUE OF PRINTOUT.
D SETVARS^BWUTL5,SORT^BWPROF2,COPYGBL,^BWPROF1,EXIT
Q
;
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
Q
;
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)
Q
;
;
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
Q
;
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
Q
;
ERRORS ;EP
;---> CALLED BY OPTION: "BW PATIENT PROFILE W/ERRORS"
;---> ENTER HERE TO INCLUDE ERRONEOUS ENTRIES.
;S BWERRORS=0 G BWPROF
Q
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
