- 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
