WVRPPCD1 ;HCIOFO/FT,JR-REPORT: PROCEDURE STATISTICS; ;7/24/01 13:55
;;1.0;WOMEN'S HEALTH;**4,12**;Sep 30, 1998
;; Original routine created by IHS/ANMC/MWR
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; DISPLAY CODE FOR PROCEDURE STATISTICS REPORT. CALLED BY WVRPPCD.
;
; This routine uses the following IAs:
; <NONE>
;
DISPLAY ;EP
;---> WVTITLE=TITLE AT TOP OF DISPLAY HEADER.
;---> WVSUBH=CODE TO EXECUTE FOR SUBHEADER (COLUMN TITLES).
;---> WVCRT=1 IF OUTPUT IS TO SCREEN (ALLOWS SELECTIONS TO EDIT).
;
U IO
W:$E(IOST)="C" @IOF
S WVTITLE="* * * WOMEN'S HEALTH: PROCEDURE STATISTICS REPORT * * *"
D CENTERT^WVUTL5(.WVTITLE)
S WVSUBH="SUBHEAD^WVRPPCD1"
D TOPHEAD^WVUTL7
S (WVPOP,N)=0
;
DISPLAY1 ;EP
N WVFAC,WVSB1
S FE="",WVFAC=0
F S FE=$O(^TMP("WVAR",$J,FE)) Q:FE=""!(WVPOP)!($G(ZTSTOP)=1) S FI=0 F S FI=$O(^TMP("WVAR",$J,FE,FI)) Q:'FI!(WVPOP)!($G(ZTSTOP)=1) D
.I WVFAC'=FI D:WVCRT&(WVFAC) DIRZ^WVUTL3 Q:WVPOP S WVFAC=FI D HEADER3 Q:$G(ZTSTOP)=1
.S N=0 F S N=$O(^TMP("WVAR",$J,FE,FI,N)) Q:N=""!(WVPOP) D
..I $Y+12>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D Q:$G(ZTSTOP)=1
...S WVPAGE=WVPAGE+1
...D HEADER3 Q:$G(ZTSTOP)=1
..S Y=^TMP("WVAR",$J,FE,FI,N)
..S WVARJ=$S($P(Y,U)["MAMMOGRAM":1,$P(Y,U)["ULTRASOUND":1,1:0)
..S WVAGRP=$$WVAGRP($P(Y,U,16))
..;---> QUIT IF DISPLAYING "ALL AGES" ONLY (NOT GROUPED BY AGE).
..Q:WVAGRP=1
..S WVPCD="< "_$P(Y,U)_": "_WVAGRP_" >",WVPCDL=$L(WVPCD)
..S X=$E(WVLINE,1,31-(WVPCDL/2))
..W !!?2,X,WVPCD,X
..I WVARJ W !?68," CREDIT"
..W !?28,"COUNT",?43,"VETS",?56,"NON-VETS"
..I WVARJ W ?66," REG. NO CR"
..W !?26,"----------",?40,"----------",?55,"----------"
..I WVARJ W ?67,"----- -----"
..D VERTICAL
..Q
.Q
I WVPOP!($G(ZTSTOP)=1) D ^%ZISC Q
D FACLIST^WVRPPCD3
N WVNAME,WVIEN,WVCNT,WVCNT1
S WVNAME="",WVCNT=0
F S WVNAME=$O(WVSB1(WVNAME)) Q:WVNAME="" D
.S WVIEN=0
.F S WVIEN=$O(WVSB1(WVNAME,WVIEN)) Q:'WVIEN D
..Q:$D(^TMP("WVAR",$J,WVNAME,WVIEN))
..S WVCNT=WVCNT+1
..Q
.Q
I WVCNT=0 G JUMP2
I '$D(^TMP("WVAR",$J)) G JUMP1
I WVCRT&('$D(IO("S")))&('WVPOP) D DIRZ^WVUTL3 D Q:WVPOP
.D:WVPOP ^%ZISC
.Q
JUMP1 ;
S WVNAME="",WVCNT1=0
F S WVNAME=$O(WVSB1(WVNAME)) Q:WVNAME=""!(WVPOP)!($G(ZTSTOP)=1) D
.S WVIEN=0
.F S WVIEN=$O(WVSB1(WVNAME,WVIEN)) Q:'WVIEN!(WVPOP)!($G(ZTSTOP)=1) D
..Q:$D(^TMP("WVAR",$J,WVNAME,WVIEN))
..S WVCNT1=WVCNT1+1,WVPAGE=1
..D HEADER4
..Q:$G(ZTSTOP)=1
..Q:WVCNT=WVCNT1
..I WVCRT&('$D(IO("S")))&('WVPOP) D DIRZ^WVUTL3
..Q
.Q
JUMP2 ;
I WVPOP!($G(ZTSTOP)=1) D ^%ZISC Q
I $O(^TMP("WVNOHCF",$J,0))'>0 D ENDREP^WVUTL7() Q
I WVCRT&('$D(IO("S")))&('WVPOP) D DIRZ^WVUTL3 D Q:WVPOP
.D:WVPOP ^%ZISC
.Q
JUMP3 ;
D NOFAC^WVRPPCD3 ;records with no facility
D ENDREP^WVUTL7()
Q
;
VERTICAL ;EP
;---> DISPLAY IN VERTICAL FORMAT.
F X=1:1:24 S:$P(Y,U,X)="" $P(Y,U,X)=0
F X=25:1:40 S:$P(Y,U,X)'>0 $P(Y,U,X)=""
D PG
W !?14,$S($P(Y,U)="PREGNANCY TEST":"NOT PREG",1:"NORMAL:")
W ?24,$J($P(Y,U,4),5),?30,"(",$J($P(Y,U,5),3),"%)"
W ?38,$J($P(Y,U,17),5),?44,PG(1),?47,$J($P(Y,U,4)-$P(Y,U,17),8)
W ?59,PG(2)
I WVARJ W ?64,$J($P(Y,U,25),5),?72,$J($P(Y,U,33),5)
W !?2,"PROCEDURES"
W ?14,$S($P(Y,U)="PREGNANCY TEST":"PREGNANT:",1:"ABNORMAL:")
W ?24,$J($P(Y,U,8),5),?30,"(",$J($P(Y,U,9),3),"%)"
W ?38,$J($P(Y,U,19),5),?44,PG(3),?47,$J($P(Y,U,8)-$P(Y,U,19),8)
W ?59,PG(4)
I WVARJ W ?64,$J($P(Y,U,27),5),?72,$J($P(Y,U,35),5)
W !?14,"NO RESULT:",?24,$J($P(Y,U,12),5),?30,"(",$J($P(Y,U,13),3),"%)"
W ?38,$J($P(Y,U,21),5),?44,PG(5),?47,$J($P(Y,U,12)-$P(Y,U,21),8)
W ?59,PG(6)
I WVARJ W ?64,$J($P(Y,U,29),5),?72,$J($P(Y,U,37),5)
W !?14,"TOTAL:",?24,$J($P(Y,U,15),5),?38,$J($P(Y,U,23),5)
W ?44,PG(7),?47,$J($P(Y,U,15)-$P(Y,U,23),8)
W ?59,PG(8)
I WVARJ W ?64,$J($P(Y,U,31),5),?72,$J($P(Y,U,39),5)
W !!?14,$S($P(Y,U)="PREGNANCY TEST":"NOT PREG:",1:"NORMAL:")
W ?24,$J($P(Y,U,2),5),?30,"(",$J($P(Y,U,3),3),"%)"
W ?38,$J($P(Y,U,18),5),?44,PG(9),?47,$J($P(Y,U,2)-$P(Y,U,18),8)
W ?59,PG(10)
I WVARJ W ?64,$J($P(Y,U,26),5),?72,$J($P(Y,U,34),5)
W !?2,"PATIENTS"
W ?14,$S($P(Y,U)="PREGNANCY TEST":"PREGNANT:",1:"ABNORMAL:")
W ?24,$J($P(Y,U,6),5),?30,"(",$J($P(Y,U,7),3),"%)"
W ?38,$J($P(Y,U,20),5),?44,PG(11),?47,$J($P(Y,U,6)-$P(Y,U,20),8)
W ?59,PG(12)
I WVARJ W ?64,$J($P(Y,U,28),5),?72,$J($P(Y,U,36),5)
W !?14,"NO RESULT:",?24,$J($P(Y,U,10),5),?30,"(",$J($P(Y,U,11),3),"%)"
W ?38,$J($P(Y,U,22),5),?44,PG(13),?47,$J($P(Y,U,10)-$P(Y,U,22),8)
W ?59,PG(14)
I WVARJ W ?64,$J($P(Y,U,30),5),?72,$J($P(Y,U,38),5)
W !?14,"TOTAL:",?24,$J($P(Y,U,14),5),?38,$J($P(Y,U,24),5)
W ?44,PG(15),?47,$J($P(Y,U,14)-$P(Y,U,24),8)
W ?59,PG(16)
I WVARJ W ?64,$J($P(Y,U,32),5),?72,$J($P(Y,U,40),5)
Q
PG ;FIGURES %'S FOR VETS & NON VETS
F JC=1:1:25 S PG(JC)=0
I $P(Y,U,4)'=0 S PG(1)=100*$P(Y,U,17)/$P(Y,U,4)
I $P(Y,U,8)'=0 S PG(3)=100*$P(Y,U,19)/$P(Y,U,8)
I $P(Y,U,12)'=0 S PG(5)=100*$P(Y,U,21)/$P(Y,U,12)
I $P(Y,U,15)'=0 S PG(7)=100*$P(Y,U,23)/$P(Y,U,15)
I $P(Y,U,2)'=0 S PG(9)=100*$P(Y,U,18)/$P(Y,U,2)
I $P(Y,U,6)'=0 S PG(11)=100*$P(Y,U,20)/$P(Y,U,6)
I $P(Y,U,10)'=0 S PG(13)=100*$P(Y,U,22)/$P(Y,U,10)
I $P(Y,U,14)'=0 S PG(15)=100*$P(Y,U,24)/$P(Y,U,14) D T
S PG(2)=$S($P(Y,U,4)'=0:100-PG(1),1:0)
S PG(4)=$S($P(Y,U,8)'=0:100-PG(3),1:0)
S PG(6)=$S($P(Y,U,12)'=0:100-PG(5),1:0)
S PG(8)=$S($P(Y,U,15)'=0:100-PG(7),1:0)
S PG(10)=$S($P(Y,U,2)'=0:100-PG(9),1:0)
S PG(12)=$S($P(Y,U,6)'=0:100-PG(11),1:0)
S PG(14)=$S($P(Y,U,10)'=0:100-PG(13),1:0)
S PG(16)=$S($P(Y,U,14)'=0:100-PG(15),1:0)
;PAD %'S WITH BLANKS
F JC=1:1:16 S PG(JC)=" "_PG(JC) D
.S PG(JC)=$E(PG(JC),$L(PG(JC))-2,$L(PG(JC)))
.S PG(JC)="("_PG(JC)_"%)"
Q
T ;ELIMINTE DECIMAL POINT IN %
N S F S=1,3,5,7,9,11,13,15 D
.S:$E($P(PG(S),".",2))'<.5 PG(S)=PG(S)+1 S PG(S)=$P(PG(S),".")
Q
;
WVAGRP(AGE) ;EP
;Q:AGE="ALL" "All ages"
Q:AGE="ALL" $S(WVAGRP'=1:"Total for selected ages",1:"All ages")
Q:AGE=1 1
N I,X,Y,Z S X=WVAGRG
F I=1:1:$L(X,",") S Y=$P($P(X,",",I),"-",2) Q:AGE'>Y
S Z=$P($P(X,",",I),"-")
Q:AGE<Z "Under "_Y_" yrs"
Q:AGE>Y "Over "_Y_" yrs"
Q $P(X,",",I)_" yrs"
;---> PUT A FINAL CHECK IN HERE?? *COMEBACK
Q "Unknown age"
;
;
SUBHEAD ;EP
;---> SUB HEADER FOR PROCEDURE BROWSE OUTPUT.
W !?5,"NOTE: Patient numbers are not intended to total. "
W "Patients may be"
W !," included in more than one category.",!
W $$REPEAT^XLFSTR("=",80)
Q
;---> REQUIRED VARIABLES: WVBEGDT,WVCRT,WVENDDT,WVPAGE,WVTITLE,DUZ(2)
;---> OPTIONAL VARIABLE: WVSUBH (SUBHEADER).
N X
W:$Y>0 @IOF
W !,WVTITLE,?70,"page: ",WVPAGE
W !,$$RUNDT^WVUTL1A("C")
W !!,"Facility: ",$$INSTTX^WVUTL6($S($G(WVFAC):WVFAC,1:DUZ(2)))
W ?53,"From: ",$$SLDT2^WVUTL5(WVBEGDT)
W " to ",$$SLDT2^WVUTL5(WVENDDT)
W !,$$REPEAT^XLFSTR("=",80)
I $D(WVSUBH) D @WVSUBH
I $D(ZTQUEUED) D STOPCHK^WVUTL10(1) Q:$G(ZTSTOP)=1
Q
N X
W:$Y>0 @IOF
W !,WVTITLE,?70,"page: ",WVPAGE
W !,$$RUNDT^WVUTL1A("C")
W !!,"Facility: "_WVNAME
W ?53,"From: ",$$SLDT2^WVUTL5(WVBEGDT)
W " to ",$$SLDT2^WVUTL5(WVENDDT)
W !,$$REPEAT^XLFSTR("=",80)
I $D(ZTQUEUED) D STOPCHK^WVUTL10(1) Q:$G(ZTSTOP)=1
W !!?5,"No records match the selected criteria for this facility.",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVRPPCD1 7335 printed Dec 13, 2024@02:47:52 Page 2
WVRPPCD1 ;HCIOFO/FT,JR-REPORT: PROCEDURE STATISTICS; ;7/24/01 13:55
+1 ;;1.0;WOMEN'S HEALTH;**4,12**;Sep 30, 1998
+2 ;; Original routine created by IHS/ANMC/MWR
+3 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+4 ;; DISPLAY CODE FOR PROCEDURE STATISTICS REPORT. CALLED BY WVRPPCD.
+5 ;
+6 ; This routine uses the following IAs:
+7 ; <NONE>
+8 ;
DISPLAY ;EP
+1 ;---> WVTITLE=TITLE AT TOP OF DISPLAY HEADER.
+2 ;---> WVSUBH=CODE TO EXECUTE FOR SUBHEADER (COLUMN TITLES).
+3 ;---> WVCRT=1 IF OUTPUT IS TO SCREEN (ALLOWS SELECTIONS TO EDIT).
+4 ;
+5 USE IO
+6 if $EXTRACT(IOST)="C"
WRITE @IOF
+7 SET WVTITLE="* * * WOMEN'S HEALTH: PROCEDURE STATISTICS REPORT * * *"
+8 DO CENTERT^WVUTL5(.WVTITLE)
+9 SET WVSUBH="SUBHEAD^WVRPPCD1"
+10 DO TOPHEAD^WVUTL7
+11 SET (WVPOP,N)=0
+12 ;
DISPLAY1 ;EP
+1 NEW WVFAC,WVSB1
+2 SET FE=""
SET WVFAC=0
+3 FOR
SET FE=$ORDER(^TMP("WVAR",$JOB,FE))
if FE=""!(WVPOP)!($GET(ZTSTOP)=1)
QUIT
SET FI=0
FOR
SET FI=$ORDER(^TMP("WVAR",$JOB,FE,FI))
if 'FI!(WVPOP)!($GET(ZTSTOP)=1)
QUIT
Begin DoDot:1
+4 IF WVFAC'=FI
if WVCRT&(WVFAC)
DO DIRZ^WVUTL3
if WVPOP
QUIT
SET WVFAC=FI
DO HEADER3
if $GET(ZTSTOP)=1
QUIT
+5 SET N=0
FOR
SET N=$ORDER(^TMP("WVAR",$JOB,FE,FI,N))
if N=""!(WVPOP)
QUIT
Begin DoDot:2
+6 IF $Y+12>IOSL
if WVCRT
DO DIRZ^WVUTL3
if WVPOP
QUIT
Begin DoDot:3
+7 SET WVPAGE=WVPAGE+1
+8 DO HEADER3
if $GET(ZTSTOP)=1
QUIT
End DoDot:3
if $GET(ZTSTOP)=1
QUIT
+9 SET Y=^TMP("WVAR",$JOB,FE,FI,N)
+10 SET WVARJ=$SELECT($PIECE(Y,U)["MAMMOGRAM":1,$PIECE(Y,U)["ULTRASOUND":1,1:0)
+11 SET WVAGRP=$$WVAGRP($PIECE(Y,U,16))
+12 ;---> QUIT IF DISPLAYING "ALL AGES" ONLY (NOT GROUPED BY AGE).
+13 if WVAGRP=1
QUIT
+14 SET WVPCD="< "_$PIECE(Y,U)_": "_WVAGRP_" >"
SET WVPCDL=$LENGTH(WVPCD)
+15 SET X=$EXTRACT(WVLINE,1,31-(WVPCDL/2))
+16 WRITE !!?2,X,WVPCD,X
+17 IF WVARJ
WRITE !?68," CREDIT"
+18 WRITE !?28,"COUNT",?43,"VETS",?56,"NON-VETS"
+19 IF WVARJ
WRITE ?66," REG. NO CR"
+20 WRITE !?26,"----------",?40,"----------",?55,"----------"
+21 IF WVARJ
WRITE ?67,"----- -----"
+22 DO VERTICAL
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
+25 IF WVPOP!($GET(ZTSTOP)=1)
DO ^%ZISC
QUIT
+26 DO FACLIST^WVRPPCD3
+27 NEW WVNAME,WVIEN,WVCNT,WVCNT1
+28 SET WVNAME=""
SET WVCNT=0
+29 FOR
SET WVNAME=$ORDER(WVSB1(WVNAME))
if WVNAME=""
QUIT
Begin DoDot:1
+30 SET WVIEN=0
+31 FOR
SET WVIEN=$ORDER(WVSB1(WVNAME,WVIEN))
if 'WVIEN
QUIT
Begin DoDot:2
+32 if $DATA(^TMP("WVAR",$JOB,WVNAME,WVIEN))
QUIT
+33 SET WVCNT=WVCNT+1
+34 QUIT
End DoDot:2
+35 QUIT
End DoDot:1
+36 IF WVCNT=0
GOTO JUMP2
+37 IF '$DATA(^TMP("WVAR",$JOB))
GOTO JUMP1
+38 IF WVCRT&('$DATA(IO("S")))&('WVPOP)
DO DIRZ^WVUTL3
Begin DoDot:1
+39 if WVPOP
DO ^%ZISC
+40 QUIT
End DoDot:1
if WVPOP
QUIT
JUMP1 ;
+1 SET WVNAME=""
SET WVCNT1=0
+2 FOR
SET WVNAME=$ORDER(WVSB1(WVNAME))
if WVNAME=""!(WVPOP)!($GET(ZTSTOP)=1)
QUIT
Begin DoDot:1
+3 SET WVIEN=0
+4 FOR
SET WVIEN=$ORDER(WVSB1(WVNAME,WVIEN))
if 'WVIEN!(WVPOP)!($GET(ZTSTOP)=1)
QUIT
Begin DoDot:2
+5 if $DATA(^TMP("WVAR",$JOB,WVNAME,WVIEN))
QUIT
+6 SET WVCNT1=WVCNT1+1
SET WVPAGE=1
+7 DO HEADER4
+8 if $GET(ZTSTOP)=1
QUIT
+9 if WVCNT=WVCNT1
QUIT
+10 IF WVCRT&('$DATA(IO("S")))&('WVPOP)
DO DIRZ^WVUTL3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
JUMP2 ;
+1 IF WVPOP!($GET(ZTSTOP)=1)
DO ^%ZISC
QUIT
+2 IF $ORDER(^TMP("WVNOHCF",$JOB,0))'>0
DO ENDREP^WVUTL7()
QUIT
+3 IF WVCRT&('$DATA(IO("S")))&('WVPOP)
DO DIRZ^WVUTL3
Begin DoDot:1
+4 if WVPOP
DO ^%ZISC
+5 QUIT
End DoDot:1
if WVPOP
QUIT
JUMP3 ;
+1 ;records with no facility
DO NOFAC^WVRPPCD3
+2 DO ENDREP^WVUTL7()
+3 QUIT
+4 ;
VERTICAL ;EP
+1 ;---> DISPLAY IN VERTICAL FORMAT.
+2 FOR X=1:1:24
if $PIECE(Y,U,X)=""
SET $PIECE(Y,U,X)=0
+3 FOR X=25:1:40
if $PIECE(Y,U,X)'>0
SET $PIECE(Y,U,X)=""
+4 DO PG
+5 WRITE !?14,$SELECT($PIECE(Y,U)="PREGNANCY TEST":"NOT PREG",1:"NORMAL:")
+6 WRITE ?24,$JUSTIFY($PIECE(Y,U,4),5),?30,"(",$JUSTIFY($PIECE(Y,U,5),3),"%)"
+7 WRITE ?38,$JUSTIFY($PIECE(Y,U,17),5),?44,PG(1),?47,$JUSTIFY($PIECE(Y,U,4)-$PIECE(Y,U,17),8)
+8 WRITE ?59,PG(2)
+9 IF WVARJ
WRITE ?64,$JUSTIFY($PIECE(Y,U,25),5),?72,$JUSTIFY($PIECE(Y,U,33),5)
+10 WRITE !?2,"PROCEDURES"
+11 WRITE ?14,$SELECT($PIECE(Y,U)="PREGNANCY TEST":"PREGNANT:",1:"ABNORMAL:")
+12 WRITE ?24,$JUSTIFY($PIECE(Y,U,8),5),?30,"(",$JUSTIFY($PIECE(Y,U,9),3),"%)"
+13 WRITE ?38,$JUSTIFY($PIECE(Y,U,19),5),?44,PG(3),?47,$JUSTIFY($PIECE(Y,U,8)-$PIECE(Y,U,19),8)
+14 WRITE ?59,PG(4)
+15 IF WVARJ
WRITE ?64,$JUSTIFY($PIECE(Y,U,27),5),?72,$JUSTIFY($PIECE(Y,U,35),5)
+16 WRITE !?14,"NO RESULT:",?24,$JUSTIFY($PIECE(Y,U,12),5),?30,"(",$JUSTIFY($PIECE(Y,U,13),3),"%)"
+17 WRITE ?38,$JUSTIFY($PIECE(Y,U,21),5),?44,PG(5),?47,$JUSTIFY($PIECE(Y,U,12)-$PIECE(Y,U,21),8)
+18 WRITE ?59,PG(6)
+19 IF WVARJ
WRITE ?64,$JUSTIFY($PIECE(Y,U,29),5),?72,$JUSTIFY($PIECE(Y,U,37),5)
+20 WRITE !?14,"TOTAL:",?24,$JUSTIFY($PIECE(Y,U,15),5),?38,$JUSTIFY($PIECE(Y,U,23),5)
+21 WRITE ?44,PG(7),?47,$JUSTIFY($PIECE(Y,U,15)-$PIECE(Y,U,23),8)
+22 WRITE ?59,PG(8)
+23 IF WVARJ
WRITE ?64,$JUSTIFY($PIECE(Y,U,31),5),?72,$JUSTIFY($PIECE(Y,U,39),5)
+24 WRITE !!?14,$SELECT($PIECE(Y,U)="PREGNANCY TEST":"NOT PREG:",1:"NORMAL:")
+25 WRITE ?24,$JUSTIFY($PIECE(Y,U,2),5),?30,"(",$JUSTIFY($PIECE(Y,U,3),3),"%)"
+26 WRITE ?38,$JUSTIFY($PIECE(Y,U,18),5),?44,PG(9),?47,$JUSTIFY($PIECE(Y,U,2)-$PIECE(Y,U,18),8)
+27 WRITE ?59,PG(10)
+28 IF WVARJ
WRITE ?64,$JUSTIFY($PIECE(Y,U,26),5),?72,$JUSTIFY($PIECE(Y,U,34),5)
+29 WRITE !?2,"PATIENTS"
+30 WRITE ?14,$SELECT($PIECE(Y,U)="PREGNANCY TEST":"PREGNANT:",1:"ABNORMAL:")
+31 WRITE ?24,$JUSTIFY($PIECE(Y,U,6),5),?30,"(",$JUSTIFY($PIECE(Y,U,7),3),"%)"
+32 WRITE ?38,$JUSTIFY($PIECE(Y,U,20),5),?44,PG(11),?47,$JUSTIFY($PIECE(Y,U,6)-$PIECE(Y,U,20),8)
+33 WRITE ?59,PG(12)
+34 IF WVARJ
WRITE ?64,$JUSTIFY($PIECE(Y,U,28),5),?72,$JUSTIFY($PIECE(Y,U,36),5)
+35 WRITE !?14,"NO RESULT:",?24,$JUSTIFY($PIECE(Y,U,10),5),?30,"(",$JUSTIFY($PIECE(Y,U,11),3),"%)"
+36 WRITE ?38,$JUSTIFY($PIECE(Y,U,22),5),?44,PG(13),?47,$JUSTIFY($PIECE(Y,U,10)-$PIECE(Y,U,22),8)
+37 WRITE ?59,PG(14)
+38 IF WVARJ
WRITE ?64,$JUSTIFY($PIECE(Y,U,30),5),?72,$JUSTIFY($PIECE(Y,U,38),5)
+39 WRITE !?14,"TOTAL:",?24,$JUSTIFY($PIECE(Y,U,14),5),?38,$JUSTIFY($PIECE(Y,U,24),5)
+40 WRITE ?44,PG(15),?47,$JUSTIFY($PIECE(Y,U,14)-$PIECE(Y,U,24),8)
+41 WRITE ?59,PG(16)
+42 IF WVARJ
WRITE ?64,$JUSTIFY($PIECE(Y,U,32),5),?72,$JUSTIFY($PIECE(Y,U,40),5)
+43 QUIT
PG ;FIGURES %'S FOR VETS & NON VETS
+1 FOR JC=1:1:25
SET PG(JC)=0
+2 IF $PIECE(Y,U,4)'=0
SET PG(1)=100*$PIECE(Y,U,17)/$PIECE(Y,U,4)
+3 IF $PIECE(Y,U,8)'=0
SET PG(3)=100*$PIECE(Y,U,19)/$PIECE(Y,U,8)
+4 IF $PIECE(Y,U,12)'=0
SET PG(5)=100*$PIECE(Y,U,21)/$PIECE(Y,U,12)
+5 IF $PIECE(Y,U,15)'=0
SET PG(7)=100*$PIECE(Y,U,23)/$PIECE(Y,U,15)
+6 IF $PIECE(Y,U,2)'=0
SET PG(9)=100*$PIECE(Y,U,18)/$PIECE(Y,U,2)
+7 IF $PIECE(Y,U,6)'=0
SET PG(11)=100*$PIECE(Y,U,20)/$PIECE(Y,U,6)
+8 IF $PIECE(Y,U,10)'=0
SET PG(13)=100*$PIECE(Y,U,22)/$PIECE(Y,U,10)
+9 IF $PIECE(Y,U,14)'=0
SET PG(15)=100*$PIECE(Y,U,24)/$PIECE(Y,U,14)
DO T
+10 SET PG(2)=$SELECT($PIECE(Y,U,4)'=0:100-PG(1),1:0)
+11 SET PG(4)=$SELECT($PIECE(Y,U,8)'=0:100-PG(3),1:0)
+12 SET PG(6)=$SELECT($PIECE(Y,U,12)'=0:100-PG(5),1:0)
+13 SET PG(8)=$SELECT($PIECE(Y,U,15)'=0:100-PG(7),1:0)
+14 SET PG(10)=$SELECT($PIECE(Y,U,2)'=0:100-PG(9),1:0)
+15 SET PG(12)=$SELECT($PIECE(Y,U,6)'=0:100-PG(11),1:0)
+16 SET PG(14)=$SELECT($PIECE(Y,U,10)'=0:100-PG(13),1:0)
+17 SET PG(16)=$SELECT($PIECE(Y,U,14)'=0:100-PG(15),1:0)
+18 ;PAD %'S WITH BLANKS
+19 FOR JC=1:1:16
SET PG(JC)=" "_PG(JC)
Begin DoDot:1
+20 SET PG(JC)=$EXTRACT(PG(JC),$LENGTH(PG(JC))-2,$LENGTH(PG(JC)))
+21 SET PG(JC)="("_PG(JC)_"%)"
End DoDot:1
+22 QUIT
T ;ELIMINTE DECIMAL POINT IN %
+1 NEW S
FOR S=1,3,5,7,9,11,13,15
Begin DoDot:1
+2 if $EXTRACT($PIECE(PG(S),".",2))'<.5
SET PG(S)=PG(S)+1
SET PG(S)=$PIECE(PG(S),".")
End DoDot:1
+3 QUIT
+4 ;
WVAGRP(AGE) ;EP
+1 ;Q:AGE="ALL" "All ages"
+2 if AGE="ALL"
QUIT $SELECT(WVAGRP'=1:"Total for selected ages",1:"All ages")
+3 if AGE=1
QUIT 1
+4 NEW I,X,Y,Z
SET X=WVAGRG
+5 FOR I=1:1:$LENGTH(X,",")
SET Y=$PIECE($PIECE(X,",",I),"-",2)
if AGE'>Y
QUIT
+6 SET Z=$PIECE($PIECE(X,",",I),"-")
+7 if AGE<Z
QUIT "Under "_Y_" yrs"
+8 if AGE>Y
QUIT "Over "_Y_" yrs"
+9 QUIT $PIECE(X,",",I)_" yrs"
+10 ;---> PUT A FINAL CHECK IN HERE?? *COMEBACK
+11 QUIT "Unknown age"
+12 ;
+13 ;
SUBHEAD ;EP
+1 ;---> SUB HEADER FOR PROCEDURE BROWSE OUTPUT.
+2 WRITE !?5,"NOTE: Patient numbers are not intended to total. "
+3 WRITE "Patients may be"
+4 WRITE !," included in more than one category.",!
+5 WRITE $$REPEAT^XLFSTR("=",80)
+6 QUIT
+1 ;---> REQUIRED VARIABLES: WVBEGDT,WVCRT,WVENDDT,WVPAGE,WVTITLE,DUZ(2)
+2 ;---> OPTIONAL VARIABLE: WVSUBH (SUBHEADER).
+3 NEW X
+4 if $Y>0
WRITE @IOF
+5 WRITE !,WVTITLE,?70,"page: ",WVPAGE
+6 WRITE !,$$RUNDT^WVUTL1A("C")
+7 WRITE !!,"Facility: ",$$INSTTX^WVUTL6($SELECT($GET(WVFAC):WVFAC,1:DUZ(2)))
+8 WRITE ?53,"From: ",$$SLDT2^WVUTL5(WVBEGDT)
+9 WRITE " to ",$$SLDT2^WVUTL5(WVENDDT)
+10 WRITE !,$$REPEAT^XLFSTR("=",80)
+11 IF $DATA(WVSUBH)
DO @WVSUBH
+12 IF $DATA(ZTQUEUED)
DO STOPCHK^WVUTL10(1)
if $GET(ZTSTOP)=1
QUIT
+13 QUIT
+1 NEW X
+2 if $Y>0
WRITE @IOF
+3 WRITE !,WVTITLE,?70,"page: ",WVPAGE
+4 WRITE !,$$RUNDT^WVUTL1A("C")
+5 WRITE !!,"Facility: "_WVNAME
+6 WRITE ?53,"From: ",$$SLDT2^WVUTL5(WVBEGDT)
+7 WRITE " to ",$$SLDT2^WVUTL5(WVENDDT)
+8 WRITE !,$$REPEAT^XLFSTR("=",80)
+9 IF $DATA(ZTQUEUED)
DO STOPCHK^WVUTL10(1)
if $GET(ZTSTOP)=1
QUIT
+10 WRITE !!?5,"No records match the selected criteria for this facility.",!
+11 QUIT
