BWBRPCD ;IHS/ANMC/MWR - BROWSE PROCEDURES;27-Feb-2003 22:26;PLS
;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CALLED BY OPTION: "BW BROWSE PROCEDURES" TO BROWSE AND EDIT
;; PROCEDURES.
;
;---> VARIABLES:
;---> BWA: 1=ALL PATIENTS, 0=ONE PATIENT
;---> BWDFN: DFN OF SELECTED PATIENT
;---> DATES: BWBEGDT=BEGINNING DATE, BWENDDT=ENDING DATE
;---> BWD: 1=BOTH ABNORMAL AND NORMAL, 0=NORMAL ONLY
;---> SORT SEQUENCE IN BWC: 1=DATE, PATIENT, PRIORITY
;---> 2=PATIENT, DATE, PRIORITY
;---> 3=PRIORITY, DATE, PATIENT
;---> USE NODES 1 & 2 IN ^TMP GLOBAL
;
D SETVARS^BWUTL5 S BWPOP=0
D ^BWBRPCD2 G:BWPOP EXIT
D SORT
D COPYGBL
;---> NEXT LINE: PASS TITLE, HEADER (IN ^BWUTL7), AND CODE TO
;---> EXECUTE BY DIR AT BOTTOM OF SCREEN.
D DISPLAY^BWBRPCD1(BWTITLE,BWHEADER,BWCODE)
;
EXIT ;EP
D KILLALL^BWUTL8
Q
;
;
SORT ;EP
;---> SORT AND STORE ARRAY IN ^TMP("BW",$J
N BWPROC
K ^TMP("BW",$J)
;---> BWBEGDT1=ONE SECOND BEFORE BEGIN DATE.
;---> BWENDDT1=THE LAST SECOND OF END DATE.
S BWBEGDT1=BWBEGDT-.0001,BWENDDT1=BWENDDT+.9999
;
;***********************
;---> BWA=1 ALL PATIENTS
I BWA D Q
.;---> BY DATE GET EITHER ALL OR ABNORMAL ONLY.
.;---> ("INSUFFICIENT TISSUE" IS INCLUDED IN ABNML XREF.)
.S BWXREF=$S(BWD:"D",1:"ABNML")
.S BWDATE=BWBEGDT1
.F S BWDATE=$O(^BWPCD(BWXREF,BWDATE)) Q:'BWDATE!(BWDATE>BWENDDT1) D
..S BWIEN=0
..F S BWIEN=$O(^BWPCD(BWXREF,BWDATE,BWIEN)) Q:'BWIEN D
...S Y=^BWPCD(BWIEN,0),BWDFN=$P(Y,U,2),BWPROC=+$P(Y,U,4)
...;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
...Q:$P(Y,U,5)=8
...;---> QUIT IF NOT SELECTING FOR ALL PROCEDURES AND IF THIS IS
...;---> NOT ONE OF THE SELECTED PROCEDURES.
...I '$D(BWARR("ALL")) Q:'$D(BWARR(BWPROC))
...;---> QUIT IF NOT "ALL PROCEDURES" AND THIS ENTRY IS "CLOSED".
...Q:BWB'="a"&($P(Y,U,14)="c")
...;---> QUIT IF SELECTING FOR ONE CASE MANAGER AND THIS DOESN'T MATCH.
...I 'BWE Q:$P(^BWP(BWDFN,0),U,10)'=BWCMGR
...;---> QUIT IF LISTING "DELINQUENT" AND THIS PROCDURE IS NOT DELINQ.
...I BWB="d" Q:$P(Y,U,13)>DT!($P(Y,U,13)="")
...;---> QUIT IF LISTING "NEW" AND THIS PROCDURE IS NOT NEW.
...Q:BWB="n"&($P(Y,U,14)'="n")
...D STORE(BWC,BWIEN,Y)
;
;**********************
;---> BWA=0 ONE PATIENT
S BWIEN=0
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
.;---> QUIT IF NOT WITHIN DATE RANGE.
.S BWDATE=$P(Y,U,12)
.Q:BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1)
.;---> QUIT IF SELECTING FOR "ABNORMAL" ONLY AND THIS PROCEDURE
.;---> "NORMAL". ("INSUFF TISSUE" AND "UNSAT EXAM" WILL BE "ABNORMAL".)
.Q:'BWD&('$$NORMAL^BWUTL4($P(Y,U,5)))
.;---> QUIT IF "DELINQUENT" OR "OPEN" ONLY AND THIS ENTRY IS "CLOSED".
.Q:BWB'="a"&($P(Y,U,14)="c")
.;---> QUIT IF LISTING "DELINQUENT" AND THIS PROCDURE IS NOT DELINQ.
.I BWB="d" Q:$P(Y,U,13)>DT!($P(Y,U,13)="")
.Q:BWB="n"&($P(Y,U,14)'="n")
.D STORE(BWC,BWIEN,Y)
Q
;
STORE(BWC,BWIEN,Y) ;EP
;---> CALLED TO STORE PROCEDURES IN ^TMP FOR BROWSING.
;---> BWC=LIST ORDER, BWIEN=IEN OR PROCEDURE, Y=ZERO NODE OF PROCEDURE.
S BWDFN=$P(Y,U,2),BWDATE=$P(Y,U,12) ;---> DFN, DATE
S BWCHRT=$$HRCN^BWUTL1(BWDFN) ;---> CHART#
S BWNAME=$$NAME^BWUTL1(BWDFN) ;---> NAME
S BWACC=$P(Y,U) ;---> ACCESSION#
S BWSTAT=$E($$STATUS^BWUTL4) ;---> STATUS
S BWDIAG=$$DIAG^BWUTL4($P(Y,U,5)) ;---> RESULT/DIAG
S X=$P(Y,U,5),BWPRIO=$$PRIOR^BWUTL4 K X ;---> PRIORITY
;
S X=BWCHRT_U_BWNAME_U_BWDATE_U_BWACC_U_BWDIAG_U_BWPRIO_U_BWSTAT_U_BWIEN
I BWC=1 S ^TMP("BW",$J,1,BWDATE,BWNAME,BWPRIO,BWIEN)=X Q
I BWC=2 S ^TMP("BW",$J,1,BWNAME,BWDATE,BWPRIO,BWIEN)=X Q
I BWC=3 S ^TMP("BW",$J,1,BWPRIO,BWDATE,BWNAME,BWIEN)=X
Q
;
COPYGBL ;EP
;---> CALLED TO FLATTEN THE ^TMP ARRAY OF PROCEDURES FOR BROWSING.
;---> 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
;---> FOR TASKMAN QUEUE OF PRINTOUT.
D SETVARS^BWUTL5,SORT,COPYGBL
D DISPLAY^BWBRPCD1(BWTITLE,BWHEADER,BWCODE)
D EXIT
Q
BWBRPCD ;IHS/ANMC/MWR - BROWSE PROCEDURES;27-Feb-2003 22:26;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" TO BROWSE AND EDIT
+4 ;; PROCEDURES.
+5 ;
+6 ;---> VARIABLES:
+7 ;---> BWA: 1=ALL PATIENTS, 0=ONE PATIENT
+8 ;---> BWDFN: DFN OF SELECTED PATIENT
+9 ;---> DATES: BWBEGDT=BEGINNING DATE, BWENDDT=ENDING DATE
+10 ;---> BWD: 1=BOTH ABNORMAL AND NORMAL, 0=NORMAL ONLY
+11 ;---> SORT SEQUENCE IN BWC: 1=DATE, PATIENT, PRIORITY
+12 ;---> 2=PATIENT, DATE, PRIORITY
+13 ;---> 3=PRIORITY, DATE, PATIENT
+14 ;---> USE NODES 1 & 2 IN ^TMP GLOBAL
+15 ;
+16 DO SETVARS^BWUTL5
SET BWPOP=0
+17 DO ^BWBRPCD2
IF BWPOP
GOTO EXIT
+18 DO SORT
+19 DO COPYGBL
+20 ;---> NEXT LINE: PASS TITLE, HEADER (IN ^BWUTL7), AND CODE TO
+21 ;---> EXECUTE BY DIR AT BOTTOM OF SCREEN.
+22 DO DISPLAY^BWBRPCD1(BWTITLE,BWHEADER,BWCODE)
+23 ;
EXIT ;EP
+1 DO KILLALL^BWUTL8
+2 QUIT
+3 ;
+4 ;
SORT ;EP
+1 ;---> SORT AND STORE ARRAY IN ^TMP("BW",$J
+2 NEW BWPROC
+3 KILL ^TMP("BW",$JOB)
+4 ;---> BWBEGDT1=ONE SECOND BEFORE BEGIN DATE.
+5 ;---> BWENDDT1=THE LAST SECOND OF END DATE.
+6 SET BWBEGDT1=BWBEGDT-.0001
SET BWENDDT1=BWENDDT+.9999
+7 ;
+8 ;***********************
+9 ;---> BWA=1 ALL PATIENTS
+10 IF BWA
Begin DoDot:1
+11 ;---> BY DATE GET EITHER ALL OR ABNORMAL ONLY.
+12 ;---> ("INSUFFICIENT TISSUE" IS INCLUDED IN ABNML XREF.)
+13 SET BWXREF=$SELECT(BWD:"D",1:"ABNML")
+14 SET BWDATE=BWBEGDT1
+15 FOR
SET BWDATE=$ORDER(^BWPCD(BWXREF,BWDATE))
IF 'BWDATE!(BWDATE>BWENDDT1)
QUIT
Begin DoDot:2
+16 SET BWIEN=0
+17 FOR
SET BWIEN=$ORDER(^BWPCD(BWXREF,BWDATE,BWIEN))
IF 'BWIEN
QUIT
Begin DoDot:3
+18 SET Y=^BWPCD(BWIEN,0)
SET BWDFN=$PIECE(Y,U,2)
SET BWPROC=+$PIECE(Y,U,4)
+19 ;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
+20 IF $PIECE(Y,U,5)=8
QUIT
+21 ;---> QUIT IF NOT SELECTING FOR ALL PROCEDURES AND IF THIS IS
+22 ;---> NOT ONE OF THE SELECTED PROCEDURES.
+23 IF '$DATA(BWARR("ALL"))
IF '$DATA(BWARR(BWPROC))
QUIT
+24 ;---> QUIT IF NOT "ALL PROCEDURES" AND THIS ENTRY IS "CLOSED".
+25 IF BWB'="a"&($PIECE(Y,U,14)="c")
QUIT
+26 ;---> QUIT IF SELECTING FOR ONE CASE MANAGER AND THIS DOESN'T MATCH.
+27 IF 'BWE
IF $PIECE(^BWP(BWDFN,0),U,10)'=BWCMGR
QUIT
+28 ;---> QUIT IF LISTING "DELINQUENT" AND THIS PROCDURE IS NOT DELINQ.
+29 IF BWB="d"
IF $PIECE(Y,U,13)>DT!($PIECE(Y,U,13)="")
QUIT
+30 ;---> QUIT IF LISTING "NEW" AND THIS PROCDURE IS NOT NEW.
+31 IF BWB="n"&($PIECE(Y,U,14)'="n")
QUIT
+32 DO STORE(BWC,BWIEN,Y)
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+33 ;
+34 ;**********************
+35 ;---> BWA=0 ONE PATIENT
+36 SET BWIEN=0
+37 FOR
SET BWIEN=$ORDER(^BWPCD("C",BWDFN,BWIEN))
IF 'BWIEN
QUIT
Begin DoDot:1
+38 ;---> SET Y=THE ZERO NODE FOR THIS PROCEDURE.
+39 SET Y=^BWPCD(BWIEN,0)
+40 ;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
+41 IF $PIECE(Y,U,5)=8
QUIT
+42 ;---> QUIT IF NOT WITHIN DATE RANGE.
+43 SET BWDATE=$PIECE(Y,U,12)
+44 IF BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1)
QUIT
+45 ;---> QUIT IF SELECTING FOR "ABNORMAL" ONLY AND THIS PROCEDURE
+46 ;---> "NORMAL". ("INSUFF TISSUE" AND "UNSAT EXAM" WILL BE "ABNORMAL".)
+47 IF 'BWD&('$$NORMAL^BWUTL4($PIECE(Y,U,5)))
QUIT
+48 ;---> QUIT IF "DELINQUENT" OR "OPEN" ONLY AND THIS ENTRY IS "CLOSED".
+49 IF BWB'="a"&($PIECE(Y,U,14)="c")
QUIT
+50 ;---> QUIT IF LISTING "DELINQUENT" AND THIS PROCDURE IS NOT DELINQ.
+51 IF BWB="d"
IF $PIECE(Y,U,13)>DT!($PIECE(Y,U,13)="")
QUIT
+52 IF BWB="n"&($PIECE(Y,U,14)'="n")
QUIT
+53 DO STORE(BWC,BWIEN,Y)
End DoDot:1
+54 QUIT
+55 ;
STORE(BWC,BWIEN,Y) ;EP
+1 ;---> CALLED TO STORE PROCEDURES IN ^TMP FOR BROWSING.
+2 ;---> BWC=LIST ORDER, BWIEN=IEN OR PROCEDURE, Y=ZERO NODE OF PROCEDURE.
+3 ;---> DFN, DATE
SET BWDFN=$PIECE(Y,U,2)
SET BWDATE=$PIECE(Y,U,12)
+4 ;---> CHART#
SET BWCHRT=$$HRCN^BWUTL1(BWDFN)
+5 ;---> NAME
SET BWNAME=$$NAME^BWUTL1(BWDFN)
+6 ;---> ACCESSION#
SET BWACC=$PIECE(Y,U)
+7 ;---> STATUS
SET BWSTAT=$EXTRACT($$STATUS^BWUTL4)
+8 ;---> RESULT/DIAG
SET BWDIAG=$$DIAG^BWUTL4($PIECE(Y,U,5))
+9 ;---> PRIORITY
SET X=$PIECE(Y,U,5)
SET BWPRIO=$$PRIOR^BWUTL4
KILL X
+10 ;
+11 SET X=BWCHRT_U_BWNAME_U_BWDATE_U_BWACC_U_BWDIAG_U_BWPRIO_U_BWSTAT_U_BWIEN
+12 IF BWC=1
SET ^TMP("BW",$JOB,1,BWDATE,BWNAME,BWPRIO,BWIEN)=X
QUIT
+13 IF BWC=2
SET ^TMP("BW",$JOB,1,BWNAME,BWDATE,BWPRIO,BWIEN)=X
QUIT
+14 IF BWC=3
SET ^TMP("BW",$JOB,1,BWPRIO,BWDATE,BWNAME,BWIEN)=X
+15 QUIT
+16 ;
COPYGBL ;EP
+1 ;---> CALLED TO FLATTEN THE ^TMP ARRAY OF PROCEDURES FOR BROWSING.
+2 ;---> COPY ^TMP("BW",$J,1 TO ^TMP("BW",$J,2 TO MAKE IT FLAT.
+3 NEW I,M,N,P,Q
+4 SET N=0
SET I=0
+5 FOR
SET N=$ORDER(^TMP("BW",$JOB,1,N))
IF N=""
QUIT
Begin DoDot:1
+6 SET M=0
+7 FOR
SET M=$ORDER(^TMP("BW",$JOB,1,N,M))
IF M=""
QUIT
Begin DoDot:2
+8 SET P=0
+9 FOR
SET P=$ORDER(^TMP("BW",$JOB,1,N,M,P))
IF P=""
QUIT
Begin DoDot:3
+10 SET Q=0
+11 FOR
SET Q=$ORDER(^TMP("BW",$JOB,1,N,M,P,Q))
IF Q=""
QUIT
Begin DoDot:4
+12 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
+13 QUIT
+14 ;
DEQUEUE ;EP
+1 ;---> FOR TASKMAN QUEUE OF PRINTOUT.
+2 DO SETVARS^BWUTL5
DO SORT
DO COPYGBL
+3 DO DISPLAY^BWBRPCD1(BWTITLE,BWHEADER,BWCODE)
+4 DO EXIT
+5 QUIT
