WVRPPCD ;HCIOFO/FT,JR-REPORT: PROCEDURES STATISTICS; ;7/23/01 13:33
;;1.0;WOMEN'S HEALTH;**12**;Sep 30, 1998
;; Original routine created by IHS/ANMC/MWR
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CALLED BY OPTION: "WV PRINT PROCEDURE STATS".
;
; This routine uses the following IAs:
; <NONE>
;
N N,R,X,T,Y,R,PG,PA,JC,J,TR,TR2,JR,JR2,CM,CM2,WVJRC,FE,FI,WVSB
K ^TMP("WVRES",$J),^TMP("WVAR",$J),^TMP("WVNOHCF",$J)
S WVPOP=0 K WVRES
D TITLE^WVUTL5("PROCEDURE STATISTICS REPORT")
D DATES G:WVPOP EXIT
D SELECT G:WVPOP EXIT
D BYAGE(.WVAGRG,.WVPOP) G:WVPOP EXIT
D FAC G:WVPOP EXIT
D DEVICE G:WVPOP EXIT
D ^WVRPPCD2
D COPYGBL
D ^WVRPPCD1
;
EXIT ;EP
K ^TMP("WVRES",$J),^TMP("WVAR",$J),^TMP("WVNOHCF",$J)
D KILLALL^WVUTL8
Q
;
DATES ;EP
;---> ASK DATE RANGE. RETURN DATES IN WVBEGDT AND WVENDDT.
D ASKDATES^WVUTL3(.WVBEGDT,.WVENDDT,.WVPOP,"T-365","T")
Q
;
SELECT ;EP
D SELECT^WVSELECT("Procedure Type",790.2,"WVARR","","",.WVPOP)
Q
;
BYAGE(WVAGRG,WVPOP) ;EP
;---> RETURN AGE RANGE IN WVAGRG.
N DIR,DIRUT,Y S WVPOP=0
W !!?3,"Do you wish to display statistics by age group?"
S DIR(0)="Y",DIR("B")="YES" D HELP1
S DIR("A")=" Enter Yes or No"
D ^DIR K DIR W !
S:$D(DIRUT) WVPOP=1
;---> IF NOT DISPLAYING BY AGE GROUP, SET WVAGRG (AGE RANGE)=1, QUIT.
I 'Y S WVAGRG=1 Q
BYAGE1 ;
W !?5,"Enter the age ranges you wish to select for in the form of:"
W !?5," 15-29,30-39,40-105"
W !?5,"Use a dash ""-"" to separate the limits of a range,"
W !?5,"use a comma to separate the different ranges."
W !!?5,"NOTE: Patient ages will reflect the age they were on the"
W !?5," dates of their procedures. Patient ages will NOT"
W !?5," necessarily be their ages today.",!
K DIR D HELP2
S DIR(0)="FOA",DIR("A")=" Enter age ranges: "
S:$D(^WV(790.72,DUZ,0)) DIR("B")=$P(^(0),U,2)
D ^DIR K DIR
I $D(DIRUT) S WVPOP=1 Q
D CHECK(.Y)
I Y="" D G BYAGE1
.W !!?5,"* INVALID AGE RANGE. Please begin again. (Enter ? for help.)"
;---> WVAGRG=SELECTED AGE RANGE(S).
S WVAGRG=Y
D DIC^WVFMAN(790.72,"L",.Y,"","","","`"_DUZ)
Q:Y<0
D DIE^WVFMAN(790.72,".02////"_WVAGRG,+Y,.WVPOP,1)
Q
;
FAC ; Select one or more facilities
D SELECT^WVSELECT("Facility",790.02,"WVSB","",DUZ(2),.WVPOP)
Q
DEVICE ;EP
;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
S ZTDESC="Procedure Statistics Report"
S ZTRTN="DEQUEUE^WVRPPCD"
F WVSV="AGRG","BEGDT","ENDDT" D
.I $D(@("WV"_WVSV)) S ZTSAVE("WV"_WVSV)=""
;---> SAVE PROCEDURES ARRAY.
I $D(WVARR) N N S N=0 F S N=$O(WVARR(N)) Q:N="" D
.S ZTSAVE("WVARR("""_N_""")")=""
; Save Facility array
I $D(WVSB) N N S N=0 F S N=$O(WVSB(N)) Q:N="" D
.S ZTSAVE("WVSB("""_N_""")")=""
.Q
D ZIS^WVUTL2(.WVPOP,1)
Q
;
COPYGBL ;EP
;---> COPY ^TMP("WVRES",$J,"R") TO ^TMP("WVAR",$J, TO MAKE IT FLAT.
N FE,FI,I,M,N K WVAR
S I=0,FE=""
F S FE=$O(^TMP("WVRES",$J,"R",FE)) Q:FE="" S FI=0 F S FI=$O(^TMP("WVRES",$J,"R",FE,FI)) Q:'FI S N=0 F S N=$O(^TMP("WVRES",$J,"R",FE,FI,N)) Q:N="" D
.S M=0
.F S M=$O(^TMP("WVRES",$J,"R",FE,FI,N,M)) Q:M="" D
..S I=I+1,^TMP("WVAR",$J,FE,FI,I)=^TMP("WVRES",$J,"R",FE,FI,N,M)
Q
;
DEQUEUE ;EP
;---> TASKMAN QUEUE OF PRINTOUT.
D SETVARS^WVUTL5,^WVRPPCD2
I $G(ZTSTOP)=1 D EXIT Q ;user requested the job to stop
D COPYGBL,^WVRPPCD1,EXIT
Q
;
HELP1 ;EP
;;Answer "YES" to display statistics by age group. If you choose
;;to display by age group, you will be given the opportunity to
;;select the age ranges. For example, you might choose to display
;;from ages 15-40,41-65,65-99.
;;Answer "NO" to display statistics without grouping by age.
S WVTAB=5,WVLINL="HELP1" D HELPTX
Q
;
HELP2 ;EP
;;Enter each age range you wish to report on by entering the
;;earlier age-dash-older age. For example, 20-29 would report
;;on all patients between the ages of 20 and 29 inclusive.
;;You may select as many age ranges as you wish. Age ranges must
;;be separated by commas. For example: 15-19,20-29,30-39
;;To select only one age, simply enter that age, with no dashes,
;;for example, 30 would report only on women who were 30 years
;;of age.
S WVTAB=5,WVLINL="HELP2" D HELPTX
Q
;
HELPTX ;EP
;---> CREATES DIR ARRAY FOR DIR. REQUIRED VARIABLES: WVTAB,WVLINL.
N I,T,X S T=$$REPEAT^XLFSTR(" ",WVTAB)
F I=1:1 S X=$T(@WVLINL+I) Q:X'[";;" S DIR("?",I)=T_$P(X,";;",2)
S DIR("?")=DIR("?",I-1) K DIR("?",I-1)
Q
;
CHECK(X) ;EP
;---> CHECK SYNTAX OF AGE RANGE STRING.
;---> IF X=ONE AGE ONLY, SET IT IN THE FORM X-X AND QUIT.
I X?1N.N S X=X_"-"_X Q
;
N WV1,FAIL,I,Y,Y1,Y2
S FAIL=0
;---> CHECK EACH RANGE.
F I=1:1:$L(X,",") S Y=$P(X,",",I) D Q:FAIL
.S Y1=$P(Y,"-"),Y2=$P(Y,"-",2)
.;---> EACH END OF EACH RANGE SHOULD BE A NUMBER.
.I (Y1'?1N.N)!(Y2'?1N.N) S FAIL=1 Q
.;---> THE LOWER NUMBER SHOULD BE FIRST.
.I Y2<Y1 S FAIL=1
I FAIL S X="" Q
;
;---> MAKE SURE ORDER IS FROM LOWEST (YOUNGEST) TO HIGHEST (OLDEST).
F I=1:1:$L(X,",") S Y=$P(X,",",I),Y1=$P(Y,"-"),WV1(Y1)=Y
S N=0,X=""
F S N=$O(WV1(N)) Q:'N S X=X_WV1(N)_","
S:$E(X,$L(X))="," X=$E(X,1,($L(X)-1))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVRPPCD 5247 printed Sep 23, 2025@20:24:10 Page 2
WVRPPCD ;HCIOFO/FT,JR-REPORT: PROCEDURES STATISTICS; ;7/23/01 13:33
+1 ;;1.0;WOMEN'S HEALTH;**12**;Sep 30, 1998
+2 ;; Original routine created by IHS/ANMC/MWR
+3 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+4 ;; CALLED BY OPTION: "WV PRINT PROCEDURE STATS".
+5 ;
+6 ; This routine uses the following IAs:
+7 ; <NONE>
+8 ;
+9 NEW N,R,X,T,Y,R,PG,PA,JC,J,TR,TR2,JR,JR2,CM,CM2,WVJRC,FE,FI,WVSB
+10 KILL ^TMP("WVRES",$JOB),^TMP("WVAR",$JOB),^TMP("WVNOHCF",$JOB)
+11 SET WVPOP=0
KILL WVRES
+12 DO TITLE^WVUTL5("PROCEDURE STATISTICS REPORT")
+13 DO DATES
if WVPOP
GOTO EXIT
+14 DO SELECT
if WVPOP
GOTO EXIT
+15 DO BYAGE(.WVAGRG,.WVPOP)
if WVPOP
GOTO EXIT
+16 DO FAC
if WVPOP
GOTO EXIT
+17 DO DEVICE
if WVPOP
GOTO EXIT
+18 DO ^WVRPPCD2
+19 DO COPYGBL
+20 DO ^WVRPPCD1
+21 ;
EXIT ;EP
+1 KILL ^TMP("WVRES",$JOB),^TMP("WVAR",$JOB),^TMP("WVNOHCF",$JOB)
+2 DO KILLALL^WVUTL8
+3 QUIT
+4 ;
DATES ;EP
+1 ;---> ASK DATE RANGE. RETURN DATES IN WVBEGDT AND WVENDDT.
+2 DO ASKDATES^WVUTL3(.WVBEGDT,.WVENDDT,.WVPOP,"T-365","T")
+3 QUIT
+4 ;
SELECT ;EP
+1 DO SELECT^WVSELECT("Procedure Type",790.2,"WVARR","","",.WVPOP)
+2 QUIT
+3 ;
BYAGE(WVAGRG,WVPOP) ;EP
+1 ;---> RETURN AGE RANGE IN WVAGRG.
+2 NEW DIR,DIRUT,Y
SET WVPOP=0
+3 WRITE !!?3,"Do you wish to display statistics by age group?"
+4 SET DIR(0)="Y"
SET DIR("B")="YES"
DO HELP1
+5 SET DIR("A")=" Enter Yes or No"
+6 DO ^DIR
KILL DIR
WRITE !
+7 if $DATA(DIRUT)
SET WVPOP=1
+8 ;---> IF NOT DISPLAYING BY AGE GROUP, SET WVAGRG (AGE RANGE)=1, QUIT.
+9 IF 'Y
SET WVAGRG=1
QUIT
BYAGE1 ;
+1 WRITE !?5,"Enter the age ranges you wish to select for in the form of:"
+2 WRITE !?5," 15-29,30-39,40-105"
+3 WRITE !?5,"Use a dash ""-"" to separate the limits of a range,"
+4 WRITE !?5,"use a comma to separate the different ranges."
+5 WRITE !!?5,"NOTE: Patient ages will reflect the age they were on the"
+6 WRITE !?5," dates of their procedures. Patient ages will NOT"
+7 WRITE !?5," necessarily be their ages today.",!
+8 KILL DIR
DO HELP2
+9 SET DIR(0)="FOA"
SET DIR("A")=" Enter age ranges: "
+10 if $DATA(^WV(790.72,DUZ,0))
SET DIR("B")=$PIECE(^(0),U,2)
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)
SET WVPOP=1
QUIT
+13 DO CHECK(.Y)
+14 IF Y=""
Begin DoDot:1
+15 WRITE !!?5,"* INVALID AGE RANGE. Please begin again. (Enter ? for help.)"
End DoDot:1
GOTO BYAGE1
+16 ;---> WVAGRG=SELECTED AGE RANGE(S).
+17 SET WVAGRG=Y
+18 DO DIC^WVFMAN(790.72,"L",.Y,"","","","`"_DUZ)
+19 if Y<0
QUIT
+20 DO DIE^WVFMAN(790.72,".02////"_WVAGRG,+Y,.WVPOP,1)
+21 QUIT
+22 ;
FAC ; Select one or more facilities
+1 DO SELECT^WVSELECT("Facility",790.02,"WVSB","",DUZ(2),.WVPOP)
+2 QUIT
DEVICE ;EP
+1 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
+2 SET ZTDESC="Procedure Statistics Report"
+3 SET ZTRTN="DEQUEUE^WVRPPCD"
+4 FOR WVSV="AGRG","BEGDT","ENDDT"
Begin DoDot:1
+5 IF $DATA(@("WV"_WVSV))
SET ZTSAVE("WV"_WVSV)=""
End DoDot:1
+6 ;---> SAVE PROCEDURES ARRAY.
+7 IF $DATA(WVARR)
NEW N
SET N=0
FOR
SET N=$ORDER(WVARR(N))
if N=""
QUIT
Begin DoDot:1
+8 SET ZTSAVE("WVARR("""_N_""")")=""
End DoDot:1
+9 ; Save Facility array
+10 IF $DATA(WVSB)
NEW N
SET N=0
FOR
SET N=$ORDER(WVSB(N))
if N=""
QUIT
Begin DoDot:1
+11 SET ZTSAVE("WVSB("""_N_""")")=""
+12 QUIT
End DoDot:1
+13 DO ZIS^WVUTL2(.WVPOP,1)
+14 QUIT
+15 ;
COPYGBL ;EP
+1 ;---> COPY ^TMP("WVRES",$J,"R") TO ^TMP("WVAR",$J, TO MAKE IT FLAT.
+2 NEW FE,FI,I,M,N
KILL WVAR
+3 SET I=0
SET FE=""
+4 FOR
SET FE=$ORDER(^TMP("WVRES",$JOB,"R",FE))
if FE=""
QUIT
SET FI=0
FOR
SET FI=$ORDER(^TMP("WVRES",$JOB,"R",FE,FI))
if 'FI
QUIT
SET N=0
FOR
SET N=$ORDER(^TMP("WVRES",$JOB,"R",FE,FI,N))
if N=""
QUIT
Begin DoDot:1
+5 SET M=0
+6 FOR
SET M=$ORDER(^TMP("WVRES",$JOB,"R",FE,FI,N,M))
if M=""
QUIT
Begin DoDot:2
+7 SET I=I+1
SET ^TMP("WVAR",$JOB,FE,FI,I)=^TMP("WVRES",$JOB,"R",FE,FI,N,M)
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
DEQUEUE ;EP
+1 ;---> TASKMAN QUEUE OF PRINTOUT.
+2 DO SETVARS^WVUTL5
DO ^WVRPPCD2
+3 ;user requested the job to stop
IF $GET(ZTSTOP)=1
DO EXIT
QUIT
+4 DO COPYGBL
DO ^WVRPPCD1
DO EXIT
+5 QUIT
+6 ;
HELP1 ;EP
+1 ;;Answer "YES" to display statistics by age group. If you choose
+2 ;;to display by age group, you will be given the opportunity to
+3 ;;select the age ranges. For example, you might choose to display
+4 ;;from ages 15-40,41-65,65-99.
+5 ;;Answer "NO" to display statistics without grouping by age.
+6 SET WVTAB=5
SET WVLINL="HELP1"
DO HELPTX
+7 QUIT
+8 ;
HELP2 ;EP
+1 ;;Enter each age range you wish to report on by entering the
+2 ;;earlier age-dash-older age. For example, 20-29 would report
+3 ;;on all patients between the ages of 20 and 29 inclusive.
+4 ;;You may select as many age ranges as you wish. Age ranges must
+5 ;;be separated by commas. For example: 15-19,20-29,30-39
+6 ;;To select only one age, simply enter that age, with no dashes,
+7 ;;for example, 30 would report only on women who were 30 years
+8 ;;of age.
+9 SET WVTAB=5
SET WVLINL="HELP2"
DO HELPTX
+10 QUIT
+11 ;
HELPTX ;EP
+1 ;---> CREATES DIR ARRAY FOR DIR. REQUIRED VARIABLES: WVTAB,WVLINL.
+2 NEW I,T,X
SET T=$$REPEAT^XLFSTR(" ",WVTAB)
+3 FOR I=1:1
SET X=$TEXT(@WVLINL+I)
if X'[";;"
QUIT
SET DIR("?",I)=T_$PIECE(X,";;",2)
+4 SET DIR("?")=DIR("?",I-1)
KILL DIR("?",I-1)
+5 QUIT
+6 ;
CHECK(X) ;EP
+1 ;---> CHECK SYNTAX OF AGE RANGE STRING.
+2 ;---> IF X=ONE AGE ONLY, SET IT IN THE FORM X-X AND QUIT.
+3 IF X?1N.N
SET X=X_"-"_X
QUIT
+4 ;
+5 NEW WV1,FAIL,I,Y,Y1,Y2
+6 SET FAIL=0
+7 ;---> CHECK EACH RANGE.
+8 FOR I=1:1:$LENGTH(X,",")
SET Y=$PIECE(X,",",I)
Begin DoDot:1
+9 SET Y1=$PIECE(Y,"-")
SET Y2=$PIECE(Y,"-",2)
+10 ;---> EACH END OF EACH RANGE SHOULD BE A NUMBER.
+11 IF (Y1'?1N.N)!(Y2'?1N.N)
SET FAIL=1
QUIT
+12 ;---> THE LOWER NUMBER SHOULD BE FIRST.
+13 IF Y2<Y1
SET FAIL=1
End DoDot:1
if FAIL
QUIT
+14 IF FAIL
SET X=""
QUIT
+15 ;
+16 ;---> MAKE SURE ORDER IS FROM LOWEST (YOUNGEST) TO HIGHEST (OLDEST).
+17 FOR I=1:1:$LENGTH(X,",")
SET Y=$PIECE(X,",",I)
SET Y1=$PIECE(Y,"-")
SET WV1(Y1)=Y
+18 SET N=0
SET X=""
+19 FOR
SET N=$ORDER(WV1(N))
if 'N
QUIT
SET X=X_WV1(N)_","
+20 if $EXTRACT(X,$LENGTH(X))=","
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+21 QUIT
