BWBRDUP ;IHS/ANMC/MWR - BROWSE DUPLICATE PROCEDURES;15-Feb-2003 21:46;PLS
;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CALLED BY OPTION: "BW BROWSE PROCEDURES DUPLICATE" TO IDENTIFY,
;; LIST AND BROWSE POSSIBLE DUPLICATE PROCEDURES.
;
;---> USE ^BWBRPCD ROUTINES FOR DISPLAY (NODES 1 & 2 IN ^TMP GLOBAL).
;
D SETVARS
D TITLE^BWUTL5("BROWSE PROCEDURES FOR POSSIBLE DUPLICATES")
D DEVICE G:BWPOP EXIT
D SORT
D COPYGBL^BWBRPCD
D DISPLAY^BWBRPCD1(BWTITLE,BWHEADER,BWCODE)
;
EXIT ;EP
D KILLALL^BWUTL8
Q
;
SETVARS ;EP
;---> SET REQUIRED VARIABLES.
D SETVARS^BWUTL5 S BWPOP=0
S BWTITLE="* * * DUPLICATE PROCEDURES LISTED BY PATIENT * * *"
;---> SET CODE EXCECUTED BY DIR PROMPT.
S BWCODE="D EDIT^BWBRPCD1,SORT^BWBRDUP,COPYGBL^BWBRPCD"
;---> SET LINE LABEL IN ^BWUTL7 TO CALL AS HEADER.
S BWHEADER="HEADER6"
Q
;
SORT ;EP
;---> SORT AND STORE ARRAY IN ^TMP("BW",$J
K ^TMP("BW",$J) N BWDFN,BWIEN,BWPCD,BWPCDS,N,M,P,Y
S BWDFN=0
F S BWDFN=$O(^BWPCD("C",BWDFN)) Q:'BWDFN D
.;
.;---> GATHER ALL PROCEDURES FOR THIS PATIENT INTO BWPCDS ARRAY.
.S BWIEN=0 K BWPCDS
.F S BWIEN=$O(^BWPCD("C",BWDFN,BWIEN)) Q:'BWIEN D
..;---> SET Y=THE ZERO NODE FOR THIS PROCEDURE.
..S Y=^BWPCD(BWIEN,0)
..;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
..Q:$P(Y,U,5)=8
..;---> GET DATE.
..S BWPCD=+$P(Y,U,4),BWDATE=+$P($P(Y,U,12),".")
..; Must have a valid procedure. WiseWoman entries lack a procedure.
..Q:'BWPCD
..S BWPCDS(BWDFN,BWDATE,BWPCD,BWIEN)=""
.;
.;---> NOW CHECK BWPCDS ARRAY FOR DUPLICATES.
.S N=0
.F S N=$O(BWPCDS(BWDFN,N)) Q:'N D
..S M=0
..F S M=$O(BWPCDS(BWDFN,N,M)) Q:'M D
...S P=0
...F I=0:1 S P=$O(BWPCDS(BWDFN,N,M,P)) Q:'P
...Q:I'>1
...S P=0
...F S P=$O(BWPCDS(BWDFN,N,M,P)) Q:'P D
....S Y=^BWPCD(P,0) D STORE^BWBRPCD(2,P,Y)
Q
;
DEQUEUE ;EP
;---> FOR TASKMAN QUEUE OF PRINTOUT.
D SETVARS,SORT,COPYGBL^BWBRPCD
D DISPLAY^BWBRPCD1(BWTITLE,BWHEADER,BWCODE)
D EXIT
Q
;
DEVICE ;EP
;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
S ZTRTN="DEQUEUE^BWBRDUP"
F BWSV="HEADER" D
.I $D(@("BW"_BWSV)) S ZTSAVE("BW"_BWSV)=""
D ZIS^BWUTL2(.BWPOP,1,"HOME")
Q
BWBRDUP ;IHS/ANMC/MWR - BROWSE DUPLICATE PROCEDURES;15-Feb-2003 21:46;PLS
+1 ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; CALLED BY OPTION: "BW BROWSE PROCEDURES DUPLICATE" TO IDENTIFY,
+4 ;; LIST AND BROWSE POSSIBLE DUPLICATE PROCEDURES.
+5 ;
+6 ;---> USE ^BWBRPCD ROUTINES FOR DISPLAY (NODES 1 & 2 IN ^TMP GLOBAL).
+7 ;
+8 DO SETVARS
+9 DO TITLE^BWUTL5("BROWSE PROCEDURES FOR POSSIBLE DUPLICATES")
+10 DO DEVICE
IF BWPOP
GOTO EXIT
+11 DO SORT
+12 DO COPYGBL^BWBRPCD
+13 DO DISPLAY^BWBRPCD1(BWTITLE,BWHEADER,BWCODE)
+14 ;
EXIT ;EP
+1 DO KILLALL^BWUTL8
+2 QUIT
+3 ;
SETVARS ;EP
+1 ;---> SET REQUIRED VARIABLES.
+2 DO SETVARS^BWUTL5
SET BWPOP=0
+3 SET BWTITLE="* * * DUPLICATE PROCEDURES LISTED BY PATIENT * * *"
+4 ;---> SET CODE EXCECUTED BY DIR PROMPT.
+5 SET BWCODE="D EDIT^BWBRPCD1,SORT^BWBRDUP,COPYGBL^BWBRPCD"
+6 ;---> SET LINE LABEL IN ^BWUTL7 TO CALL AS HEADER.
+7 SET BWHEADER="HEADER6"
+8 QUIT
+9 ;
SORT ;EP
+1 ;---> SORT AND STORE ARRAY IN ^TMP("BW",$J
+2 KILL ^TMP("BW",$JOB)
NEW BWDFN,BWIEN,BWPCD,BWPCDS,N,M,P,Y
+3 SET BWDFN=0
+4 FOR
SET BWDFN=$ORDER(^BWPCD("C",BWDFN))
IF 'BWDFN
QUIT
Begin DoDot:1
+5 ;
+6 ;---> GATHER ALL PROCEDURES FOR THIS PATIENT INTO BWPCDS ARRAY.
+7 SET BWIEN=0
KILL BWPCDS
+8 FOR
SET BWIEN=$ORDER(^BWPCD("C",BWDFN,BWIEN))
IF 'BWIEN
QUIT
Begin DoDot:2
+9 ;---> SET Y=THE ZERO NODE FOR THIS PROCEDURE.
+10 SET Y=^BWPCD(BWIEN,0)
+11 ;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
+12 IF $PIECE(Y,U,5)=8
QUIT
+13 ;---> GET DATE.
+14 SET BWPCD=+$PIECE(Y,U,4)
SET BWDATE=+$PIECE($PIECE(Y,U,12),".")
+15 ; Must have a valid procedure. WiseWoman entries lack a procedure.
+16 IF 'BWPCD
QUIT
+17 SET BWPCDS(BWDFN,BWDATE,BWPCD,BWIEN)=""
End DoDot:2
+18 ;
+19 ;---> NOW CHECK BWPCDS ARRAY FOR DUPLICATES.
+20 SET N=0
+21 FOR
SET N=$ORDER(BWPCDS(BWDFN,N))
IF 'N
QUIT
Begin DoDot:2
+22 SET M=0
+23 FOR
SET M=$ORDER(BWPCDS(BWDFN,N,M))
IF 'M
QUIT
Begin DoDot:3
+24 SET P=0
+25 FOR I=0:1
SET P=$ORDER(BWPCDS(BWDFN,N,M,P))
IF 'P
QUIT
+26 IF I'>1
QUIT
+27 SET P=0
+28 FOR
SET P=$ORDER(BWPCDS(BWDFN,N,M,P))
IF 'P
QUIT
Begin DoDot:4
+29 SET Y=^BWPCD(P,0)
DO STORE^BWBRPCD(2,P,Y)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+30 QUIT
+31 ;
DEQUEUE ;EP
+1 ;---> FOR TASKMAN QUEUE OF PRINTOUT.
+2 DO SETVARS
DO SORT
DO COPYGBL^BWBRPCD
+3 DO DISPLAY^BWBRPCD1(BWTITLE,BWHEADER,BWCODE)
+4 DO EXIT
+5 QUIT
+6 ;
DEVICE ;EP
+1 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
+2 SET ZTRTN="DEQUEUE^BWBRDUP"
+3 FOR BWSV="HEADER"
Begin DoDot:1
+4 IF $DATA(@("BW"_BWSV))
SET ZTSAVE("BW"_BWSV)=""
End DoDot:1
+5 DO ZIS^BWUTL2(.BWPOP,1,"HOME")
+6 QUIT
