BWPROF ;IHS/ANMC/MWR - DISPLAY PATIENT PROFILE; [ 09/17/2001 7:55 AM ]
;;2.0;WOMEN'S HEALTH;**1,6,8**;MAY 16, 1996
;;* 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.
;
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
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
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)
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
;
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.
;---> THIS ENTIRE CALL HAS BEEN ADDED AS A PATCH. IHS/ANMC/MWR 11/20/96
;IHS/CMI/THL PATCH 8 BWEXT SET FOR EXTERNAL CALL SO DEVICE ISN'T CLOSED
Q:'$G(BWDFN)
Q:$G(BWD)="" ;did not pass brief/detailed
Q:'$D(^BWP(BWDFN,0))
D EN^XBNEW("EP1^BWPROF","BWDFN;BWD")
Q
EP1 ;EP called by xbnew
D SETVARS^BWUTL5 S BWERRORS=1,BWPUSER=1
D SORT^BWPROF2
D COPYGBL
D ^BWPROF1
Q
BWPROF ;IHS/ANMC/MWR - DISPLAY PATIENT PROFILE; [ 09/17/2001 7:55 AM ]
+1 ;;2.0;WOMEN'S HEALTH;**1,6,8**;MAY 16, 1996
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; CALL ED BY OPTION: "BW PATIENT PROFILE" TO DISPLAY PROFILE.
+4 ;; PATCHED AT LINELABEL PROFCALL. IHS/ANMC/MWR 11/20/96
+5 ;
+6 ;---> *NOTE: TO ASK DATE RANGE, UNCOMMENT ALL LINES WITH "XDATES",
+7 ;---> AND IN HEADER2^BWUTL7.
+8 ;
+9 ;---> VARIABLES:
+10 ;---> BWDFN: DFN OF SELECTED PATIENT
+11 ;---> DATES: BWBEGDT=BEGINNING DATE, BWENDDT=ENDING DATE
+12 ;---> USE NODES 1 & 2 IN ^TMP GLOBAL.
+13 ;
+14 DO SETVARS^BWUTL5
+15 IF '$DATA(BWERRORS)
SET BWERRORS=1
+16 FOR
DO RUN
IF BWPOP
QUIT
+17 DO EXIT
+18 QUIT
+19 ;
RUN ;EP
+1 DO TITLE^BWUTL5("PATIENT PROFILE")
+2 DO PATIENT
IF BWPOP
QUIT
+3 ;D DATES Q:BWPOP
+4 DO BRIEF
IF BWPOP
QUIT
+5 DO DEVICE
IF BWPOP
QUIT
+6 DO SORT^BWPROF2
+7 DO COPYGBL
+8 DO ^BWPROF1
SET BWPOP=0
+9 KILL BWD,BWSUBH
+10 QUIT
+11 ;
EXIT ;EP
+1 DO KILLALL^BWUTL8
+2 QUIT
+3 ;
+4 ;
PATIENT ;EP
+1 ;---> SELECT PATIENT (RETURN BWDFN).
+2 WRITE !!," Select the patient whose Profile you wish to display."
+3 DO PATLKUP^BWUTL8(.Y)
IF Y<0
SET 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 SET BWDFN=+Y
+7 QUIT
+8 ;
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 NEW DIR,DIRUT,Y
+4 WRITE !!?3,"List Patient Profile in BRIEF or DETAILED format?"
+5 SET DIR("A")=" Select BRIEF or DETAILED: "
SET DIR("B")="BRIEF"
+6 SET DIR(0)="SAM^b:BRIEF;d:DETAILED"
DO HELP1
+7 DO ^DIR
+8 IF Y=-1!($DATA(DIRUT))
SET BWPOP=1
QUIT
+9 ;---> IF ALL DETAILED, S BWD=1; FOR BRIEF BWD=0
+10 SET BWD=$SELECT(Y="d":1,1:0)
+11 QUIT
+12 ;
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 DO BWPROF
KILL 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 IF '$GET(BWDFN)
Begin DoDot:1
+7 WRITE !?5,"Patient DFN was not passed. Please contact your site manager."
+8 DO DIRZ^BWUTL3
End DoDot:1
QUIT
+9 IF '$DATA(^BWP(BWDFN,0))
Begin DoDot:1
+10 WRITE !?5,"This patient is not currently in the Women's Health Database."
+11 DO DIRZ^BWUTL3
End DoDot:1
QUIT
+12 NEW (BWDFN)
+13 DO SETVARS^BWUTL5
SET BWERRORS=1
SET BWPUSER=1
+14 DO BRIEF
IF BWPOP
QUIT
+15 DO DEVICE
IF BWPOP
QUIT
+16 DO SORT^BWPROF2
+17 DO COPYGBL
+18 DO ^BWPROF1
+19 QUIT
+20 ;
ERRORS ;EP
+1 ;---> CALLED BY OPTION: "BW PATIENT PROFILE W/ERRORS"
+2 ;---> ENTER HERE TO INCLUDE ERRONEOUS ENTRIES.
+3 SET BWERRORS=0
GOTO BWPROF
+4 QUIT
+5 ;
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 ;---> THIS ENTIRE CALL HAS BEEN ADDED AS A PATCH. IHS/ANMC/MWR 11/20/96
+8 ;IHS/CMI/THL PATCH 8 BWEXT SET FOR EXTERNAL CALL SO DEVICE ISN'T CLOSED
+9 IF '$GET(BWDFN)
QUIT
+10 ;did not pass brief/detailed
IF $GET(BWD)=""
QUIT
+11 IF '$DATA(^BWP(BWDFN,0))
QUIT
+12 DO EN^XBNEW("EP1^BWPROF","BWDFN;BWD")
+13 QUIT
EP1 ;EP called by xbnew
+1 DO SETVARS^BWUTL5
SET BWERRORS=1
SET BWPUSER=1
+2 DO SORT^BWPROF2
+3 DO COPYGBL
+4 DO ^BWPROF1
+5 QUIT
