WVDIAG ;HCIOFO/FT,JR IHS/ANMC/MWR - PRINTOUT OF WV DIAGNOSIS FILE; ;8/10/98 14:56
;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CALLED BY OPTION: "WV PRINT RES/DIAG FILE" TO PRINT THE
;; RESULTS/DIAGNOSIS TABLE FILE.
;
D SETUP
D TITLE^WVUTL5("LISTING OF RESULTS/DIAGNOSIS FILE")
D DEVICE I WVPOP D EXIT Q
D SORT
D DISPLAY
;
EXIT ;EP
D KILLALL^WVUTL8
Q
;
SETUP ;EP
D SETVARS^WVUTL5 S WVPOP=0
S WVLINE=$$REPEAT^XLFSTR("-",80)
Q
;
DEVICE ;EP
;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
S ZTRTN="DEQUEUE^WVDIAG"
F WVSV="WVLINE","WVTITLE" D
.I $D(WVSV) S ZTSAVE(WVSV)=""
D ZIS^WVUTL2(.WVPOP,1)
Q
;
SORT ;EP
;---> SORT BY RESULT/DIAGNOSIS. STORED IN ^TMP("WV",$J,1
N N,X,Y K ^TMP("WV",$J)
S N=0
F S N=$O(^WV(790.31,"B",N)) Q:N="" D
.S M=$O(^WV(790.31,"B",N,0))
.S Y=^WV(790.31,M,0),WVDIAG=N
.F I=3:1:19 I $P(Y,U,I) D
..S WVPN=$E($P(^WV(790.2,$P(Y,U,I),0),U),1,30)
..S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
..S WVPRIO=$P(Y,U,2)
..S X=WVDIAG_U_WVPRIO_U_WVNORM_U_WVPN
..S ^TMP("WV",$J,1,WVDIAG,WVPN,1)=X
.I $P(Y,U,20) D
..S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
..S WVPRIO=$P(Y,U,2),WVPN="ALL PROCEDURES"
..S X=WVDIAG_U_WVPRIO_U_WVNORM_U_WVPN
..S ^TMP("WV",$J,1,WVDIAG,WVPN,1)=X
;
;---> SORT BY PROCEDURE TYPE. STORED IN ^TMP("WV",$J,2
S N=0
F S N=$O(^WV(790.31,"P",N)) Q:N="" D
.S M=0
.F S M=$O(^WV(790.31,"P",N,M)) Q:M="" D
..S Y=^WV(790.31,M,0)
..S WVPN=$P(^WV(790.2,N,0),U),WVDIAG=$P(Y,U)
..S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
..S WVPRIO=$P(Y,U,2)
..S X=WVPN_U_WVDIAG_U_WVPRIO_U_WVNORM
..S ^TMP("WV",$J,2,WVPN,WVPRIO,WVDIAG)=X
;
;---> ASSOCIATED WITH ALL PROCEDURES
S N=0
F S N=$O(^WV(790.31,N)) Q:'N D
.S Y=^WV(790.31,N,0)
.Q:'$P(Y,U,20)
.S WVDIAG=$P(Y,U),WVPRIO=$P(Y,U,2)
.S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
.S M=0
.F S M=$O(^WV(790.2,M)) Q:'M D
..S WVPN=$P(^WV(790.2,M,0),U)
..Q:$P(^WV(790.2,M,0),U,12)
..S X=WVPN_U_WVDIAG_U_WVPRIO_U_WVNORM
..S ^TMP("WV",$J,2,WVPN,WVPRIO,WVDIAG)=X
;
;---> SORT BY PRIORITY. STORED IN ^TMP("WV",$J,3
S N=0
F S N=$O(^WV(790.31,"B",N)) Q:N="" D
.S M=$O(^WV(790.31,"B",N,0))
.S Y=^WV(790.31,M,0),WVDIAG=N,WVPRIO=$P(Y,U,2)
.S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
.S X=WVDIAG_U_WVPRIO_U_WVNORM
.S ^TMP("WV",$J,3,WVPRIO,WVDIAG,1)=X
;
;---> COPY TO TMP IN A SINGLE SUBSCRIPT.
F WVS=1,2,3 S WVSS=WVS_WVS D COPYGBL
Q
;
DISPLAY ;EP
U IO
S WVTITLE1="* WOMEN'S HEALTH: LISTING OF RESULTS/DIAGNOSIS FILE *"
D CENTERT^WVUTL5(.WVTITLE1)
S WVCRT=$S($E(IOST)="C":1,1:0),(WVPAGE,WVPOP)=0
F WVI=22,33,11 D @("DISPLY"_WVI) Q:WVPOP
D ^%ZISC
Q
;
DISPLY11 ;EP
;---> LIST BY RESULT/DIAGNOSIS
;Q
S WVTITLE2=" * BY DIAGNOSIS *" D CENTERT^WVUTL5(.WVTITLE2)
S WVSUB="W !?3,""RESULT/DIAGNOSIS"",?31,""PRIORITY"",?42,""NORMAL"","
S WVSUB=WVSUB_"?50,""ASSOCIATED PROCEDURES"""
N Z S (WVPOP,N,Z)=0
W:WVCRT @IOF D HEADER
F S N=$O(^TMP("WV",$J,WVI,N)) Q:'N!(WVPOP) D
.I $Y+8>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D HEADER
.S Y=^TMP("WV",$J,WVI,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 WVCRT&('WVPOP) W !! D DIRZ^WVUTL3
Q
;
DISPLY22 ;EP
;---> LIST BY RESULT/DIAGNOSIS
S WVTITLE2=" * BY PROCEDURE *" D CENTERT^WVUTL5(.WVTITLE2)
S WVSUB="W !?3,""PROCEDURE"",?35,""RESULT/DIAGNOSIS"""
S WVSUB=WVSUB_",?62,""PRIORITY"",?72,""NORMAL"""
N Z S (WVPOP,N,Z)=0
W:WVCRT @IOF D HEADER
F S N=$O(^TMP("WV",$J,WVI,N)) Q:'N!(WVPOP) D
.I $Y+6>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D HEADER
.S Y=^TMP("WV",$J,WVI,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 WVCRT&('WVPOP) W !! D DIRZ^WVUTL3
Q
;
DISPLY33 ;EP
;---> LIST BY RESULT/DIAGNOSIS
S WVTITLE2=" * BY PRIORITY *" D CENTERT^WVUTL5(.WVTITLE2)
S WVSUB="W !?3,""RESULT/DIAGNOSIS"",?32,""PRIORITY"",?44,""NORMAL"""
N Z S (WVPOP,N,Z)=0
W:WVCRT @IOF D HEADER
F S N=$O(^TMP("WV",$J,WVI,N)) Q:'N!(WVPOP) D
.I $Y+6>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D HEADER
.S Y=^TMP("WV",$J,WVI,N)
.W !?3,$P(Y,U),?37,$J($P(Y,U,2),2),?44,$P(Y,U,3)
.S Z=$P(Y,U)
I WVCRT&('WVPOP) W !! D DIRZ^WVUTL3
Q
;
;
W:WVPAGE @IOF S WVPAGE=WVPAGE+1,Z=0
W WVTITLE1,?70,"PAGE ",WVPAGE,!,WVTITLE2
W !,$$RUNDT^WVUTL1A("C")
W !,WVLINE X WVSUB W !,WVLINE
Q
;
COPYGBL ;EP
;---> COPY ^TMP("WV",$J,WVS TO ^TMP("WV",$J,WVSS TO MAKE IT FLAT.
N I,M,N,P,Q
S N=0,I=0
F S N=$O(^TMP("WV",$J,WVS,N)) Q:N="" D
.S M=0
.F S M=$O(^TMP("WV",$J,WVS,N,M)) Q:M="" D
..S P=0
..F S P=$O(^TMP("WV",$J,WVS,N,M,P)) Q:P="" D
...S I=I+1,^TMP("WV",$J,WVSS,I)=^TMP("WV",$J,WVS,N,M,P)
Q
;
DEQUEUE ;EP
;---> CALLED BY TASKMAN
D SETVARS^WVUTL5,SORT,DISPLAY,EXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVDIAG 4976 printed Oct 16, 2024@18:47:21 Page 2
WVDIAG ;HCIOFO/FT,JR IHS/ANMC/MWR - PRINTOUT OF WV DIAGNOSIS FILE; ;8/10/98 14:56
+1 ;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; CALLED BY OPTION: "WV PRINT RES/DIAG FILE" TO PRINT THE
+4 ;; RESULTS/DIAGNOSIS TABLE FILE.
+5 ;
+6 DO SETUP
+7 DO TITLE^WVUTL5("LISTING OF RESULTS/DIAGNOSIS FILE")
+8 DO DEVICE
IF WVPOP
DO EXIT
QUIT
+9 DO SORT
+10 DO DISPLAY
+11 ;
EXIT ;EP
+1 DO KILLALL^WVUTL8
+2 QUIT
+3 ;
SETUP ;EP
+1 DO SETVARS^WVUTL5
SET WVPOP=0
+2 SET WVLINE=$$REPEAT^XLFSTR("-",80)
+3 QUIT
+4 ;
DEVICE ;EP
+1 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
+2 SET ZTRTN="DEQUEUE^WVDIAG"
+3 FOR WVSV="WVLINE","WVTITLE"
Begin DoDot:1
+4 IF $DATA(WVSV)
SET ZTSAVE(WVSV)=""
End DoDot:1
+5 DO ZIS^WVUTL2(.WVPOP,1)
+6 QUIT
+7 ;
SORT ;EP
+1 ;---> SORT BY RESULT/DIAGNOSIS. STORED IN ^TMP("WV",$J,1
+2 NEW N,X,Y
KILL ^TMP("WV",$JOB)
+3 SET N=0
+4 FOR
SET N=$ORDER(^WV(790.31,"B",N))
if N=""
QUIT
Begin DoDot:1
+5 SET M=$ORDER(^WV(790.31,"B",N,0))
+6 SET Y=^WV(790.31,M,0)
SET WVDIAG=N
+7 FOR I=3:1:19
IF $PIECE(Y,U,I)
Begin DoDot:2
+8 SET WVPN=$EXTRACT($PIECE(^WV(790.2,$PIECE(Y,U,I),0),U),1,30)
+9 SET X=$PIECE(Y,U,21)
SET WVNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
+10 SET WVPRIO=$PIECE(Y,U,2)
+11 SET X=WVDIAG_U_WVPRIO_U_WVNORM_U_WVPN
+12 SET ^TMP("WV",$JOB,1,WVDIAG,WVPN,1)=X
End DoDot:2
+13 IF $PIECE(Y,U,20)
Begin DoDot:2
+14 SET X=$PIECE(Y,U,21)
SET WVNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
+15 SET WVPRIO=$PIECE(Y,U,2)
SET WVPN="ALL PROCEDURES"
+16 SET X=WVDIAG_U_WVPRIO_U_WVNORM_U_WVPN
+17 SET ^TMP("WV",$JOB,1,WVDIAG,WVPN,1)=X
End DoDot:2
End DoDot:1
+18 ;
+19 ;---> SORT BY PROCEDURE TYPE. STORED IN ^TMP("WV",$J,2
+20 SET N=0
+21 FOR
SET N=$ORDER(^WV(790.31,"P",N))
if N=""
QUIT
Begin DoDot:1
+22 SET M=0
+23 FOR
SET M=$ORDER(^WV(790.31,"P",N,M))
if M=""
QUIT
Begin DoDot:2
+24 SET Y=^WV(790.31,M,0)
+25 SET WVPN=$PIECE(^WV(790.2,N,0),U)
SET WVDIAG=$PIECE(Y,U)
+26 SET X=$PIECE(Y,U,21)
SET WVNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
+27 SET WVPRIO=$PIECE(Y,U,2)
+28 SET X=WVPN_U_WVDIAG_U_WVPRIO_U_WVNORM
+29 SET ^TMP("WV",$JOB,2,WVPN,WVPRIO,WVDIAG)=X
End DoDot:2
End DoDot:1
+30 ;
+31 ;---> ASSOCIATED WITH ALL PROCEDURES
+32 SET N=0
+33 FOR
SET N=$ORDER(^WV(790.31,N))
if 'N
QUIT
Begin DoDot:1
+34 SET Y=^WV(790.31,N,0)
+35 if '$PIECE(Y,U,20)
QUIT
+36 SET WVDIAG=$PIECE(Y,U)
SET WVPRIO=$PIECE(Y,U,2)
+37 SET X=$PIECE(Y,U,21)
SET WVNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
+38 SET M=0
+39 FOR
SET M=$ORDER(^WV(790.2,M))
if 'M
QUIT
Begin DoDot:2
+40 SET WVPN=$PIECE(^WV(790.2,M,0),U)
+41 if $PIECE(^WV(790.2,M,0),U,12)
QUIT
+42 SET X=WVPN_U_WVDIAG_U_WVPRIO_U_WVNORM
+43 SET ^TMP("WV",$JOB,2,WVPN,WVPRIO,WVDIAG)=X
End DoDot:2
End DoDot:1
+44 ;
+45 ;---> SORT BY PRIORITY. STORED IN ^TMP("WV",$J,3
+46 SET N=0
+47 FOR
SET N=$ORDER(^WV(790.31,"B",N))
if N=""
QUIT
Begin DoDot:1
+48 SET M=$ORDER(^WV(790.31,"B",N,0))
+49 SET Y=^WV(790.31,M,0)
SET WVDIAG=N
SET WVPRIO=$PIECE(Y,U,2)
+50 SET X=$PIECE(Y,U,21)
SET WVNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
+51 SET X=WVDIAG_U_WVPRIO_U_WVNORM
+52 SET ^TMP("WV",$JOB,3,WVPRIO,WVDIAG,1)=X
End DoDot:1
+53 ;
+54 ;---> COPY TO TMP IN A SINGLE SUBSCRIPT.
+55 FOR WVS=1,2,3
SET WVSS=WVS_WVS
DO COPYGBL
+56 QUIT
+57 ;
DISPLAY ;EP
+1 USE IO
+2 SET WVTITLE1="* WOMEN'S HEALTH: LISTING OF RESULTS/DIAGNOSIS FILE *"
+3 DO CENTERT^WVUTL5(.WVTITLE1)
+4 SET WVCRT=$SELECT($EXTRACT(IOST)="C":1,1:0)
SET (WVPAGE,WVPOP)=0
+5 FOR WVI=22,33,11
DO @("DISPLY"_WVI)
if WVPOP
QUIT
+6 DO ^%ZISC
+7 QUIT
+8 ;
DISPLY11 ;EP
+1 ;---> LIST BY RESULT/DIAGNOSIS
+2 ;Q
+3 SET WVTITLE2=" * BY DIAGNOSIS *"
DO CENTERT^WVUTL5(.WVTITLE2)
+4 SET WVSUB="W !?3,""RESULT/DIAGNOSIS"",?31,""PRIORITY"",?42,""NORMAL"","
+5 SET WVSUB=WVSUB_"?50,""ASSOCIATED PROCEDURES"""
+6 NEW Z
SET (WVPOP,N,Z)=0
+7 if WVCRT
WRITE @IOF
DO HEADER
+8 FOR
SET N=$ORDER(^TMP("WV",$JOB,WVI,N))
if 'N!(WVPOP)
QUIT
Begin DoDot:1
+9 IF $Y+8>IOSL
if WVCRT
DO DIRZ^WVUTL3
if WVPOP
QUIT
DO HEADER
+10 SET Y=^TMP("WV",$JOB,WVI,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 WVCRT&('WVPOP)
WRITE !!
DO DIRZ^WVUTL3
+15 QUIT
+16 ;
DISPLY22 ;EP
+1 ;---> LIST BY RESULT/DIAGNOSIS
+2 SET WVTITLE2=" * BY PROCEDURE *"
DO CENTERT^WVUTL5(.WVTITLE2)
+3 SET WVSUB="W !?3,""PROCEDURE"",?35,""RESULT/DIAGNOSIS"""
+4 SET WVSUB=WVSUB_",?62,""PRIORITY"",?72,""NORMAL"""
+5 NEW Z
SET (WVPOP,N,Z)=0
+6 if WVCRT
WRITE @IOF
DO HEADER
+7 FOR
SET N=$ORDER(^TMP("WV",$JOB,WVI,N))
if 'N!(WVPOP)
QUIT
Begin DoDot:1
+8 IF $Y+6>IOSL
if WVCRT
DO DIRZ^WVUTL3
if WVPOP
QUIT
DO HEADER
+9 SET Y=^TMP("WV",$JOB,WVI,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 WVCRT&('WVPOP)
WRITE !!
DO DIRZ^WVUTL3
+14 QUIT
+15 ;
DISPLY33 ;EP
+1 ;---> LIST BY RESULT/DIAGNOSIS
+2 SET WVTITLE2=" * BY PRIORITY *"
DO CENTERT^WVUTL5(.WVTITLE2)
+3 SET WVSUB="W !?3,""RESULT/DIAGNOSIS"",?32,""PRIORITY"",?44,""NORMAL"""
+4 NEW Z
SET (WVPOP,N,Z)=0
+5 if WVCRT
WRITE @IOF
DO HEADER
+6 FOR
SET N=$ORDER(^TMP("WV",$JOB,WVI,N))
if 'N!(WVPOP)
QUIT
Begin DoDot:1
+7 IF $Y+6>IOSL
if WVCRT
DO DIRZ^WVUTL3
if WVPOP
QUIT
DO HEADER
+8 SET Y=^TMP("WV",$JOB,WVI,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 WVCRT&('WVPOP)
WRITE !!
DO DIRZ^WVUTL3
+12 QUIT
+13 ;
+14 ;
+1 if WVPAGE
WRITE @IOF
SET WVPAGE=WVPAGE+1
SET Z=0
+2 WRITE WVTITLE1,?70,"PAGE ",WVPAGE,!,WVTITLE2
+3 WRITE !,$$RUNDT^WVUTL1A("C")
+4 WRITE !,WVLINE
XECUTE WVSUB
WRITE !,WVLINE
+5 QUIT
+6 ;
COPYGBL ;EP
+1 ;---> COPY ^TMP("WV",$J,WVS TO ^TMP("WV",$J,WVSS TO MAKE IT FLAT.
+2 NEW I,M,N,P,Q
+3 SET N=0
SET I=0
+4 FOR
SET N=$ORDER(^TMP("WV",$JOB,WVS,N))
if N=""
QUIT
Begin DoDot:1
+5 SET M=0
+6 FOR
SET M=$ORDER(^TMP("WV",$JOB,WVS,N,M))
if M=""
QUIT
Begin DoDot:2
+7 SET P=0
+8 FOR
SET P=$ORDER(^TMP("WV",$JOB,WVS,N,M,P))
if P=""
QUIT
Begin DoDot:3
+9 SET I=I+1
SET ^TMP("WV",$JOB,WVSS,I)=^TMP("WV",$JOB,WVS,N,M,P)
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
DEQUEUE ;EP
+1 ;---> CALLED BY TASKMAN
+2 DO SETVARS^WVUTL5
DO SORT
DO DISPLAY
DO EXIT
+3 QUIT
