BWDIAG ;IHS/ANMC/MWR - PRINTOUT OF BW DIAGNOSIS FILE;15-Feb-2003 21:50;PLS
;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CALLED BY OPTION: "BW PRINT RES/DIAG FILE" TO PRINT THE
;; RESULTS/DIAGNOSIS TABLE FILE.
;
D SETUP
D TITLE^BWUTL5("LISTING OF RESULTS/DIAGNOSIS FILE")
D DEVICE Q:BWPOP
D SORT
D DISPLAY
;
EXIT ;EP
D KILLALL^BWUTL8
Q
;
SETUP ;EP
D SETVARS^BWUTL5 S BWPOP=0
S BWLINE="-" F I=1:1:79 S BWLINE=BWLINE_"-"
Q
;
DEVICE ;EP
;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
S ZTRTN="DEQUEUE^BWDIAG"
F BWSV="BWLINE","BWTITLE" D
.I $D(BWSV) S ZTSAVE(BWSV)=""
D ZIS^BWUTL2(.BWPOP,1)
Q
;
SORT ;EP
;---> SORT BY RESULT/DIAGNOSIS. STORED IN ^TMP("BW",$J,1
N N,X,Y K ^TMP("BW",$J)
S N=0
F S N=$O(^BWDIAG("B",N)) Q:N="" D
.S M=$O(^BWDIAG("B",N,0))
.S Y=^BWDIAG(M,0),BWDIAG=N
.F I=3:1:19 I $P(Y,U,I) D
..S BWPN=$E($P(^BWPN($P(Y,U,I),0),U),1,30)
..S X=$P(Y,U,21),BWNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
..S BWPRIO=$P(Y,U,2)
..S X=BWDIAG_U_BWPRIO_U_BWNORM_U_BWPN
..S ^TMP("BW",$J,1,BWDIAG,BWPN,1)=X
.I $P(Y,U,20) D
..S X=$P(Y,U,21),BWNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
..S BWPRIO=$P(Y,U,2),BWPN="ALL PROCEDURES"
..S X=BWDIAG_U_BWPRIO_U_BWNORM_U_BWPN
..S ^TMP("BW",$J,1,BWDIAG,BWPN,1)=X
;
;---> SORT BY PROCEDURE TYPE. STORED IN ^TMP("BW",$J,2
S N=0
F S N=$O(^BWDIAG("P",N)) Q:N="" D
.S M=0
.F S M=$O(^BWDIAG("P",N,M)) Q:M="" D
..S Y=^BWDIAG(M,0)
..S BWPN=$P(^BWPN(N,0),U),BWDIAG=$P(Y,U)
..S X=$P(Y,U,21),BWNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
..S BWPRIO=$P(Y,U,2)
..S X=BWPN_U_BWDIAG_U_BWPRIO_U_BWNORM
..S ^TMP("BW",$J,2,BWPN,BWPRIO,BWDIAG)=X
;
;---> ASSOCIATED WITH ALL PROCEDURES
S N=0
F S N=$O(^BWDIAG(N)) Q:'N D
.S Y=^BWDIAG(N,0)
.Q:'$P(Y,U,20)
.S BWDIAG=$P(Y,U),BWPRIO=$P(Y,U,2)
.S X=$P(Y,U,21),BWNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
.S M=0
.F S M=$O(^BWPN(M)) Q:'M D
..S BWPN=$P(^BWPN(M,0),U)
..Q:$P(^BWPN(M,0),U,12)
..S X=BWPN_U_BWDIAG_U_BWPRIO_U_BWNORM
..S ^TMP("BW",$J,2,BWPN,BWPRIO,BWDIAG)=X
;
;---> SORT BY PRIORITY. STORED IN ^TMP("BW",$J,3
S N=0
F S N=$O(^BWDIAG("B",N)) Q:N="" D
.S M=$O(^BWDIAG("B",N,0))
.S Y=^BWDIAG(M,0),BWDIAG=N,BWPRIO=$P(Y,U,2)
.S X=$P(Y,U,21),BWNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
.S X=BWDIAG_U_BWPRIO_U_BWNORM
.S ^TMP("BW",$J,3,BWPRIO,BWDIAG,1)=X
;
;---> COPY TO TMP IN A SINGLE SUBSCRIPT.
F BWS=1,2,3 S BWSS=BWS_BWS D COPYGBL
Q
;
DISPLAY ;EP
U IO
S BWTITLE1="* WOMEN'S HEALTH: LISTING OF RESULTS/DIAGNOSIS FILE *"
D CENTERT^BWUTL5(.BWTITLE1)
S BWCRT=$S($E(IOST)="C":1,1:0),(BWPAGE,BWPOP)=0
F BWI=22,33,11 D @("DISPLY"_BWI) Q:BWPOP
W:'BWCRT @IOF
D ^%ZISC
Q
;
DISPLY11 ;EP
;---> LIST BY RESULT/DIAGNOSIS
;Q
S BWTITLE2=" * BY DIAGNOSIS *" D CENTERT^BWUTL5(.BWTITLE2)
S BWSUB="W !?3,""RESULT/DIAGNOSIS"",?31,""PRIORITY"",?42,""NORMAL"","
S BWSUB=BWSUB_"?50,""ASSOCIATED PROCEDURES"""
N Z S (BWPOP,N,Z)=0
W:BWCRT @IOF D HEADER
F S N=$O(^TMP("BW",$J,BWI,N)) Q:'N!(BWPOP) D
.I $Y+8>IOSL D:BWCRT DIRZ^BWUTL3 Q:BWPOP D HEADER
.S Y=^TMP("BW",$J,BWI,N) W !
.I $P(Y,U)'=Z W !?3,$P(Y,U),?37,$J($P(Y,U,2),2),?42,$P(Y,U,3)
.W ?50,$P(Y,U,4)
.S Z=$P(Y,U)
I BWCRT&('BWPOP) W !! D DIRZ^BWUTL3
Q
;
DISPLY22 ;EP
;---> LIST BY RESULT/DIAGNOSIS
S BWTITLE2=" * BY PROCEDURE *" D CENTERT^BWUTL5(.BWTITLE2)
S BWSUB="W !?3,""PROCEDURE"",?35,""RESULT/DIAGNOSIS"""
S BWSUB=BWSUB_",?62,""PRIORITY"",?72,""NORMAL"""
N Z S (BWPOP,N,Z)=0
W:BWCRT @IOF D HEADER
F S N=$O(^TMP("BW",$J,BWI,N)) Q:'N!(BWPOP) D
.I $Y+6>IOSL D:BWCRT DIRZ^BWUTL3 Q:BWPOP D HEADER
.S Y=^TMP("BW",$J,BWI,N) W !
.I $P(Y,U)'=Z W !?3,$P(Y,U)
.W ?35,$P(Y,U,2),?68,$J($P(Y,U,3),2),?72,$P(Y,U,4)
.S Z=$P(Y,U)
I BWCRT&('BWPOP) W !! D DIRZ^BWUTL3
Q
;
DISPLY33 ;EP
;---> LIST BY RESULT/DIAGNOSIS
S BWTITLE2=" * BY PRIORITY *" D CENTERT^BWUTL5(.BWTITLE2)
S BWSUB="W !?3,""RESULT/DIAGNOSIS"",?32,""PRIORITY"",?44,""NORMAL"""
N Z S (BWPOP,N,Z)=0
W:BWCRT @IOF D HEADER
F S N=$O(^TMP("BW",$J,BWI,N)) Q:'N!(BWPOP) D
.I $Y+6>IOSL D:BWCRT DIRZ^BWUTL3 Q:BWPOP D HEADER
.S Y=^TMP("BW",$J,BWI,N)
.W !?3,$P(Y,U),?37,$J($P(Y,U,2),2),?44,$P(Y,U,3)
.S Z=$P(Y,U)
I BWCRT&('BWPOP) W !! D DIRZ^BWUTL3
Q
;
;
W:BWPAGE @IOF S BWPAGE=BWPAGE+1,Z=0
W BWTITLE1,?70,"PAGE ",BWPAGE,!,BWTITLE2
W !,BWLINE X BWSUB W !,BWLINE
Q
;
COPYGBL ;EP
;---> COPY ^TMP("BW",$J,BWS TO ^TMP("BW",$J,BWSS TO MAKE IT FLAT.
N I,M,N,P,Q
S N=0,I=0
F S N=$O(^TMP("BW",$J,BWS,N)) Q:N="" D
.S M=0
.F S M=$O(^TMP("BW",$J,BWS,N,M)) Q:M="" D
..S P=0
..F S P=$O(^TMP("BW",$J,BWS,N,M,P)) Q:P="" D
...S I=I+1,^TMP("BW",$J,BWSS,I)=^TMP("BW",$J,BWS,N,M,P)
Q
;
DEQUEUE ;EP
;---> CALLED BY TASKMAN
D SETVARS^BWUTL5,SORT,DISPLAY,EXIT
Q
BWDIAG ;IHS/ANMC/MWR - PRINTOUT OF BW DIAGNOSIS FILE;15-Feb-2003 21:50;PLS
+1 ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; CALLED BY OPTION: "BW PRINT RES/DIAG FILE" TO PRINT THE
+4 ;; RESULTS/DIAGNOSIS TABLE FILE.
+5 ;
+6 DO SETUP
+7 DO TITLE^BWUTL5("LISTING OF RESULTS/DIAGNOSIS FILE")
+8 DO DEVICE
IF BWPOP
QUIT
+9 DO SORT
+10 DO DISPLAY
+11 ;
EXIT ;EP
+1 DO KILLALL^BWUTL8
+2 QUIT
+3 ;
SETUP ;EP
+1 DO SETVARS^BWUTL5
SET BWPOP=0
+2 SET BWLINE="-"
FOR I=1:1:79
SET BWLINE=BWLINE_"-"
+3 QUIT
+4 ;
DEVICE ;EP
+1 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
+2 SET ZTRTN="DEQUEUE^BWDIAG"
+3 FOR BWSV="BWLINE","BWTITLE"
Begin DoDot:1
+4 IF $DATA(BWSV)
SET ZTSAVE(BWSV)=""
End DoDot:1
+5 DO ZIS^BWUTL2(.BWPOP,1)
+6 QUIT
+7 ;
SORT ;EP
+1 ;---> SORT BY RESULT/DIAGNOSIS. STORED IN ^TMP("BW",$J,1
+2 NEW N,X,Y
KILL ^TMP("BW",$JOB)
+3 SET N=0
+4 FOR
SET N=$ORDER(^BWDIAG("B",N))
IF N=""
QUIT
Begin DoDot:1
+5 SET M=$ORDER(^BWDIAG("B",N,0))
+6 SET Y=^BWDIAG(M,0)
SET BWDIAG=N
+7 FOR I=3:1:19
IF $PIECE(Y,U,I)
Begin DoDot:2
+8 SET BWPN=$EXTRACT($PIECE(^BWPN($PIECE(Y,U,I),0),U),1,30)
+9 SET X=$PIECE(Y,U,21)
SET BWNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
+10 SET BWPRIO=$PIECE(Y,U,2)
+11 SET X=BWDIAG_U_BWPRIO_U_BWNORM_U_BWPN
+12 SET ^TMP("BW",$JOB,1,BWDIAG,BWPN,1)=X
End DoDot:2
+13 IF $PIECE(Y,U,20)
Begin DoDot:2
+14 SET X=$PIECE(Y,U,21)
SET BWNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
+15 SET BWPRIO=$PIECE(Y,U,2)
SET BWPN="ALL PROCEDURES"
+16 SET X=BWDIAG_U_BWPRIO_U_BWNORM_U_BWPN
+17 SET ^TMP("BW",$JOB,1,BWDIAG,BWPN,1)=X
End DoDot:2
End DoDot:1
+18 ;
+19 ;---> SORT BY PROCEDURE TYPE. STORED IN ^TMP("BW",$J,2
+20 SET N=0
+21 FOR
SET N=$ORDER(^BWDIAG("P",N))
IF N=""
QUIT
Begin DoDot:1
+22 SET M=0
+23 FOR
SET M=$ORDER(^BWDIAG("P",N,M))
IF M=""
QUIT
Begin DoDot:2
+24 SET Y=^BWDIAG(M,0)
+25 SET BWPN=$PIECE(^BWPN(N,0),U)
SET BWDIAG=$PIECE(Y,U)
+26 SET X=$PIECE(Y,U,21)
SET BWNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
+27 SET BWPRIO=$PIECE(Y,U,2)
+28 SET X=BWPN_U_BWDIAG_U_BWPRIO_U_BWNORM
+29 SET ^TMP("BW",$JOB,2,BWPN,BWPRIO,BWDIAG)=X
End DoDot:2
End DoDot:1
+30 ;
+31 ;---> ASSOCIATED WITH ALL PROCEDURES
+32 SET N=0
+33 FOR
SET N=$ORDER(^BWDIAG(N))
IF 'N
QUIT
Begin DoDot:1
+34 SET Y=^BWDIAG(N,0)
+35 IF '$PIECE(Y,U,20)
QUIT
+36 SET BWDIAG=$PIECE(Y,U)
SET BWPRIO=$PIECE(Y,U,2)
+37 SET X=$PIECE(Y,U,21)
SET BWNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
+38 SET M=0
+39 FOR
SET M=$ORDER(^BWPN(M))
IF 'M
QUIT
Begin DoDot:2
+40 SET BWPN=$PIECE(^BWPN(M,0),U)
+41 IF $PIECE(^BWPN(M,0),U,12)
QUIT
+42 SET X=BWPN_U_BWDIAG_U_BWPRIO_U_BWNORM
+43 SET ^TMP("BW",$JOB,2,BWPN,BWPRIO,BWDIAG)=X
End DoDot:2
End DoDot:1
+44 ;
+45 ;---> SORT BY PRIORITY. STORED IN ^TMP("BW",$J,3
+46 SET N=0
+47 FOR
SET N=$ORDER(^BWDIAG("B",N))
IF N=""
QUIT
Begin DoDot:1
+48 SET M=$ORDER(^BWDIAG("B",N,0))
+49 SET Y=^BWDIAG(M,0)
SET BWDIAG=N
SET BWPRIO=$PIECE(Y,U,2)
+50 SET X=$PIECE(Y,U,21)
SET BWNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
+51 SET X=BWDIAG_U_BWPRIO_U_BWNORM
+52 SET ^TMP("BW",$JOB,3,BWPRIO,BWDIAG,1)=X
End DoDot:1
+53 ;
+54 ;---> COPY TO TMP IN A SINGLE SUBSCRIPT.
+55 FOR BWS=1,2,3
SET BWSS=BWS_BWS
DO COPYGBL
+56 QUIT
+57 ;
DISPLAY ;EP
+1 USE IO
+2 SET BWTITLE1="* WOMEN'S HEALTH: LISTING OF RESULTS/DIAGNOSIS FILE *"
+3 DO CENTERT^BWUTL5(.BWTITLE1)
+4 SET BWCRT=$SELECT($EXTRACT(IOST)="C":1,1:0)
SET (BWPAGE,BWPOP)=0
+5 FOR BWI=22,33,11
DO @("DISPLY"_BWI)
IF BWPOP
QUIT
+6 IF 'BWCRT
WRITE @IOF
+7 DO ^%ZISC
+8 QUIT
+9 ;
DISPLY11 ;EP
+1 ;---> LIST BY RESULT/DIAGNOSIS
+2 ;Q
+3 SET BWTITLE2=" * BY DIAGNOSIS *"
DO CENTERT^BWUTL5(.BWTITLE2)
+4 SET BWSUB="W !?3,""RESULT/DIAGNOSIS"",?31,""PRIORITY"",?42,""NORMAL"","
+5 SET BWSUB=BWSUB_"?50,""ASSOCIATED PROCEDURES"""
+6 NEW Z
SET (BWPOP,N,Z)=0
+7 IF BWCRT
WRITE @IOF
DO HEADER
+8 FOR
SET N=$ORDER(^TMP("BW",$JOB,BWI,N))
IF 'N!(BWPOP)
QUIT
Begin DoDot:1
+9 IF $Y+8>IOSL
IF BWCRT
DO DIRZ^BWUTL3
IF BWPOP
QUIT
DO HEADER
+10 SET Y=^TMP("BW",$JOB,BWI,N)
WRITE !
+11 IF $PIECE(Y,U)'=Z
WRITE !?3,$PIECE(Y,U),?37,$JUSTIFY($PIECE(Y,U,2),2),?42,$PIECE(Y,U,3)
+12 WRITE ?50,$PIECE(Y,U,4)
+13 SET Z=$PIECE(Y,U)
End DoDot:1
+14 IF BWCRT&('BWPOP)
WRITE !!
DO DIRZ^BWUTL3
+15 QUIT
+16 ;
DISPLY22 ;EP
+1 ;---> LIST BY RESULT/DIAGNOSIS
+2 SET BWTITLE2=" * BY PROCEDURE *"
DO CENTERT^BWUTL5(.BWTITLE2)
+3 SET BWSUB="W !?3,""PROCEDURE"",?35,""RESULT/DIAGNOSIS"""
+4 SET BWSUB=BWSUB_",?62,""PRIORITY"",?72,""NORMAL"""
+5 NEW Z
SET (BWPOP,N,Z)=0
+6 IF BWCRT
WRITE @IOF
DO HEADER
+7 FOR
SET N=$ORDER(^TMP("BW",$JOB,BWI,N))
IF 'N!(BWPOP)
QUIT
Begin DoDot:1
+8 IF $Y+6>IOSL
IF BWCRT
DO DIRZ^BWUTL3
IF BWPOP
QUIT
DO HEADER
+9 SET Y=^TMP("BW",$JOB,BWI,N)
WRITE !
+10 IF $PIECE(Y,U)'=Z
WRITE !?3,$PIECE(Y,U)
+11 WRITE ?35,$PIECE(Y,U,2),?68,$JUSTIFY($PIECE(Y,U,3),2),?72,$PIECE(Y,U,4)
+12 SET Z=$PIECE(Y,U)
End DoDot:1
+13 IF BWCRT&('BWPOP)
WRITE !!
DO DIRZ^BWUTL3
+14 QUIT
+15 ;
DISPLY33 ;EP
+1 ;---> LIST BY RESULT/DIAGNOSIS
+2 SET BWTITLE2=" * BY PRIORITY *"
DO CENTERT^BWUTL5(.BWTITLE2)
+3 SET BWSUB="W !?3,""RESULT/DIAGNOSIS"",?32,""PRIORITY"",?44,""NORMAL"""
+4 NEW Z
SET (BWPOP,N,Z)=0
+5 IF BWCRT
WRITE @IOF
DO HEADER
+6 FOR
SET N=$ORDER(^TMP("BW",$JOB,BWI,N))
IF 'N!(BWPOP)
QUIT
Begin DoDot:1
+7 IF $Y+6>IOSL
IF BWCRT
DO DIRZ^BWUTL3
IF BWPOP
QUIT
DO HEADER
+8 SET Y=^TMP("BW",$JOB,BWI,N)
+9 WRITE !?3,$PIECE(Y,U),?37,$JUSTIFY($PIECE(Y,U,2),2),?44,$PIECE(Y,U,3)
+10 SET Z=$PIECE(Y,U)
End DoDot:1
+11 IF BWCRT&('BWPOP)
WRITE !!
DO DIRZ^BWUTL3
+12 QUIT
+13 ;
+14 ;
+1 IF BWPAGE
WRITE @IOF
SET BWPAGE=BWPAGE+1
SET Z=0
+2 WRITE BWTITLE1,?70,"PAGE ",BWPAGE,!,BWTITLE2
+3 WRITE !,BWLINE
XECUTE BWSUB
WRITE !,BWLINE
+4 QUIT
+5 ;
COPYGBL ;EP
+1 ;---> COPY ^TMP("BW",$J,BWS TO ^TMP("BW",$J,BWSS 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,BWS,N))
IF N=""
QUIT
Begin DoDot:1
+5 SET M=0
+6 FOR
SET M=$ORDER(^TMP("BW",$JOB,BWS,N,M))
IF M=""
QUIT
Begin DoDot:2
+7 SET P=0
+8 FOR
SET P=$ORDER(^TMP("BW",$JOB,BWS,N,M,P))
IF P=""
QUIT
Begin DoDot:3
+9 SET I=I+1
SET ^TMP("BW",$JOB,BWSS,I)=^TMP("BW",$JOB,BWS,N,M,P)
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
DEQUEUE ;EP
+1 ;---> CALLED BY TASKMAN
+2 DO SETVARS^BWUTL5
DO SORT
DO DISPLAY
DO EXIT
+3 QUIT
