WVBRDUP ;HCIOFO/FT,JR IHS/ANMC/MWR - BROWSE DUPLICATE PROCEDURES;
;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CALLED BY OPTION: "WV BROWSE PROCEDURES DUPLICATE" TO IDENTIFY,
;; LIST AND BROWSE POSSIBLE DUPLICATE PROCEDURES.
;
;---> USE ^WVBRPCD ROUTINES FOR DISPLAY (NODES 1 & 2 IN ^TMP GLOBAL).
;
D SETVARS
D TITLE^WVUTL5("BROWSE PROCEDURES FOR POSSIBLE DUPLICATES")
D DEVICE G:WVPOP EXIT
D SORT
D COPYGBL^WVBRPCD
D DISPLAY^WVBRPCD1(WVTITLE,WVHEADER,WVCODE)
;
EXIT ;EP
D KILLALL^WVUTL8
Q
;
SETVARS ;EP
;---> SET REQUIRED VARIABLES.
D SETVARS^WVUTL5 S WVPOP=0
S WVTITLE="* * * DUPLICATE PROCEDURES LISTED BY PATIENT * * *"
;---> SET CODE EXCECUTED BY DIR PROMPT.
S WVCODE="D EDIT^WVBRPCD1,SORT^WVBRDUP,COPYGBL^WVBRPCD"
;---> SET LINE LABEL IN ^WVUTL7 TO CALL AS HEADER.
S WVHEADER="HEADER6"
Q
;
SORT ;EP
;---> SORT AND STORE ARRAY IN ^TMP("WV",$J
K ^TMP("WV",$J) N WVDFN,WVIEN,WVPCD,WVPCDS,N,M,P,Y
S WVDFN=0
F S WVDFN=$O(^WV(790.1,"C",WVDFN)) Q:'WVDFN D
.;
.;---> GATHER ALL PROCEDURES FOR THIS PATIENT INTO WVPCDS ARRAY.
.S WVIEN=0 K WVPCDS
.F S WVIEN=$O(^WV(790.1,"C",WVDFN,WVIEN)) Q:'WVIEN D
..;---> SET Y=THE ZERO NODE FOR THIS PROCEDURE.
..S Y=^WV(790.1,WVIEN,0)
..;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
..Q:$P(Y,U,5)=8
..;---> GET DATE.
..S WVPCD=$P(Y,U,4),WVDATE=$P($P(Y,U,12),".")
..S WVPCDS(WVDFN,WVDATE,WVPCD,WVIEN)=""
.;
.;---> NOW CHECK WVPCDS ARRAY FOR DUPLICATES.
.S N=0
.F S N=$O(WVPCDS(WVDFN,N)) Q:'N D
..S M=0
..F S M=$O(WVPCDS(WVDFN,N,M)) Q:'M D
...S P=0
...F I=0:1 S P=$O(WVPCDS(WVDFN,N,M,P)) Q:'P
...Q:I'>1
...S P=0
...F S P=$O(WVPCDS(WVDFN,N,M,P)) Q:'P D
....S Y=^WV(790.1,P,0) D STORE^WVBRPCD(2,P,Y)
Q
;
DEQUEUE ;EP
;---> FOR TASKMAN QUEUE OF PRINTOUT.
D SETVARS,SORT,COPYGBL^WVBRPCD
D DISPLAY^WVBRPCD1(WVTITLE,WVHEADER,WVCODE)
D EXIT
Q
;
DEVICE ;EP
;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
S ZTRTN="DEQUEUE^WVBRDUP"
F WVSV="HEADER" D
.I $D(@("WV"_WVSV)) S ZTSAVE("WV"_WVSV)=""
D ZIS^WVUTL2(.WVPOP,1,"HOME")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVBRDUP 2172 printed Dec 13, 2024@02:46:42 Page 2
WVBRDUP ;HCIOFO/FT,JR IHS/ANMC/MWR - BROWSE DUPLICATE PROCEDURES;
+1 ;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; CALLED BY OPTION: "WV BROWSE PROCEDURES DUPLICATE" TO IDENTIFY,
+4 ;; LIST AND BROWSE POSSIBLE DUPLICATE PROCEDURES.
+5 ;
+6 ;---> USE ^WVBRPCD ROUTINES FOR DISPLAY (NODES 1 & 2 IN ^TMP GLOBAL).
+7 ;
+8 DO SETVARS
+9 DO TITLE^WVUTL5("BROWSE PROCEDURES FOR POSSIBLE DUPLICATES")
+10 DO DEVICE
if WVPOP
GOTO EXIT
+11 DO SORT
+12 DO COPYGBL^WVBRPCD
+13 DO DISPLAY^WVBRPCD1(WVTITLE,WVHEADER,WVCODE)
+14 ;
EXIT ;EP
+1 DO KILLALL^WVUTL8
+2 QUIT
+3 ;
SETVARS ;EP
+1 ;---> SET REQUIRED VARIABLES.
+2 DO SETVARS^WVUTL5
SET WVPOP=0
+3 SET WVTITLE="* * * DUPLICATE PROCEDURES LISTED BY PATIENT * * *"
+4 ;---> SET CODE EXCECUTED BY DIR PROMPT.
+5 SET WVCODE="D EDIT^WVBRPCD1,SORT^WVBRDUP,COPYGBL^WVBRPCD"
+6 ;---> SET LINE LABEL IN ^WVUTL7 TO CALL AS HEADER.
+7 SET WVHEADER="HEADER6"
+8 QUIT
+9 ;
SORT ;EP
+1 ;---> SORT AND STORE ARRAY IN ^TMP("WV",$J
+2 KILL ^TMP("WV",$JOB)
NEW WVDFN,WVIEN,WVPCD,WVPCDS,N,M,P,Y
+3 SET WVDFN=0
+4 FOR
SET WVDFN=$ORDER(^WV(790.1,"C",WVDFN))
if 'WVDFN
QUIT
Begin DoDot:1
+5 ;
+6 ;---> GATHER ALL PROCEDURES FOR THIS PATIENT INTO WVPCDS ARRAY.
+7 SET WVIEN=0
KILL WVPCDS
+8 FOR
SET WVIEN=$ORDER(^WV(790.1,"C",WVDFN,WVIEN))
if 'WVIEN
QUIT
Begin DoDot:2
+9 ;---> SET Y=THE ZERO NODE FOR THIS PROCEDURE.
+10 SET Y=^WV(790.1,WVIEN,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 WVPCD=$PIECE(Y,U,4)
SET WVDATE=$PIECE($PIECE(Y,U,12),".")
+15 SET WVPCDS(WVDFN,WVDATE,WVPCD,WVIEN)=""
End DoDot:2
+16 ;
+17 ;---> NOW CHECK WVPCDS ARRAY FOR DUPLICATES.
+18 SET N=0
+19 FOR
SET N=$ORDER(WVPCDS(WVDFN,N))
if 'N
QUIT
Begin DoDot:2
+20 SET M=0
+21 FOR
SET M=$ORDER(WVPCDS(WVDFN,N,M))
if 'M
QUIT
Begin DoDot:3
+22 SET P=0
+23 FOR I=0:1
SET P=$ORDER(WVPCDS(WVDFN,N,M,P))
if 'P
QUIT
+24 if I'>1
QUIT
+25 SET P=0
+26 FOR
SET P=$ORDER(WVPCDS(WVDFN,N,M,P))
if 'P
QUIT
Begin DoDot:4
+27 SET Y=^WV(790.1,P,0)
DO STORE^WVBRPCD(2,P,Y)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+28 QUIT
+29 ;
DEQUEUE ;EP
+1 ;---> FOR TASKMAN QUEUE OF PRINTOUT.
+2 DO SETVARS
DO SORT
DO COPYGBL^WVBRPCD
+3 DO DISPLAY^WVBRPCD1(WVTITLE,WVHEADER,WVCODE)
+4 DO EXIT
+5 QUIT
+6 ;
DEVICE ;EP
+1 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
+2 SET ZTRTN="DEQUEUE^WVBRDUP"
+3 FOR WVSV="HEADER"
Begin DoDot:1
+4 IF $DATA(@("WV"_WVSV))
SET ZTSAVE("WV"_WVSV)=""
End DoDot:1
+5 DO ZIS^WVUTL2(.WVPOP,1,"HOME")
+6 QUIT
