BWRPPCD ;IHS/ANMC/MWR - REPORT: PROCEDURES STATISTICS;15-Feb-2003 22:09;PLS
;;2.0;WOMEN'S HEALTH;**6,8**;MAY 16, 1996
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CALLED BY OPTION: "BW PRINT PROCEDURE STATS".
;
D SETVARS^BWUTL5 S BWPOP=0 K BWRES
D TITLE^BWUTL5("PROCEDURE STATISTICS REPORT")
D DATES G:BWPOP EXIT
D SELECT G:BWPOP EXIT
D CURCOM G:BWPOP EXIT ;IHS/CMI/LAB - added current community screen
D BYAGE(.BWAGRG,.BWPOP) G:BWPOP EXIT
D DEVICE G:BWPOP EXIT
D ^BWRPPCD2
D COPYGBL
D ^BWRPPCD1
;
EXIT ;EP
D KILLALL^BWUTL8
Q
;
;
DATES ;EP
;---> ASK DATE RANGE. RETURN DATES IN BWBEGDT AND BWENDDT.
D ASKDATES^BWUTL3(.BWBEGDT,.BWENDDT,.BWPOP,"T-365","T")
Q
;
SELECT ;EP
D SELECT^BWSELECT("Procedure Type",9002086.2,"BWARR","","",.BWPOP)
Q
;
CURCOM ;
;IHS/CMI/LAB - added this subroutine to screen on current comm
;---> SELECT CASES FOR ONE OR MORE CURRENT COMMUNITY (OR ALL).
;---> DO NOT PROMPT FOR CURRENT COMMUNITY IF THIS IS A VA SITE.
I $$AGENCY^BWUTL5(DUZ(2))'="i" D Q ;IHS/ANMC/MWR 11/20/96
.S BWCC("ALL")="" ;IHS/ANMC/MWR 11/20/96
;---> SELECT CURRENT COMMUNITY(S).
D TEXT2^BWRPSCR K BWTAB,BWLINL
;D SELECT^BWSELECT("Current Community",9999999.05,"BWCC","","",.BWPOP)
K BWCC
S DIR(0)="S^O:One particular Community;A:All Communities;S:Selected Set of Communities (Taxonomy)",DIR("A")="List children who live in",DIR("B")="O" K DA D ^DIR K DIR
I $D(DIRUT) S BWPOP=1 Q
I Y="A" W !!,"All communities will be included in the report.",! S BWCC("ALL")="" Q
I Y="O" D Q:$D(BWCC) I 1
.S DIC="^AUTTCOM(",DIC(0)="AEMQ",DIC("A")="Which COMMUNITY: " D ^DIC K DIC
.Q:Y=-1
.S BWCC($P(^AUTTCOM(+Y,0),U))=""
S X="COMMUNITY",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" G CURCOM
D ^AMQQGTX0(+Y,"BWCC(")
I '$D(BWCC) G CURCOM
I $D(BWCC("*")) S BWCC("ALL")=""
Q
;
BYAGE(BWAGRG,BWPOP) ;EP
;---> RETURN AGE RANGE IN BWAGRG.
N DIR,DIRUT,Y S BWPOP=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) BWPOP=1
;---> IF NOT DISPLAYING BY AGE GROUP, SET BWAGRG (AGE RANGE)=1, QUIT.
I 'Y S BWAGRG=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(^BWAGDF(DUZ,0)) DIR("B")=$P(^(0),U,2)
D ^DIR K DIR
I $D(DIRUT) S BWPOP=1 Q
D CHECK(.Y)
I Y="" D G BYAGE1
.W !!?5,"* INVALID AGE RANGE. Please begin again. (Enter ? for help.)"
;---> BWAGRG=SELECTED AGE RANGE(S).
S BWAGRG=Y
D DIC^BWFMAN(9002086.72,"L",.Y,"","","","`"_DUZ)
Q:Y<0
D DIE^BWFMAN(9002086.72,".02////"_BWAGRG,+Y,.BWPOP,1)
Q
;
DEVICE ;EP
;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
S ZTRTN="DEQUEUE^BWRPPCD"
F BWSV="AGRG","BEGDT","ENDDT" D
.I $D(@("BW"_BWSV)) S ZTSAVE("BW"_BWSV)=""
;---> SAVE PROCEDURES ARRAY.
I $D(BWARR) N N S N=0 F S N=$O(BWARR(N)) Q:N="" D
.S ZTSAVE("BWARR("""_N_""")")=""
D ZIS^BWUTL2(.BWPOP,1)
Q
;
COPYGBL ;EP
;---> COPY BWRES("R") TO BWAR( TO MAKE IT FLAT.
N I,M,N K BWAR
S N=0,I=0
F S N=$O(BWRES("R",N)) Q:N="" D
.S M=0
.F S M=$O(BWRES("R",N,M)) Q:M="" D
..S I=I+1,BWAR(I)=BWRES("R",N,M)
Q
;
;
DEQUEUE ;EP
;---> TASKMAN QUEUE OF PRINTOUT.
D SETVARS^BWUTL5,^BWRPPCD2,COPYGBL,^BWRPPCD1,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 BWTAB=5,BWLINL="HELP1" D HELPTX
Q
;
HELP2 ;EP
;;Enter each age range you which 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 BWTAB=5,BWLINL="HELP2" D HELPTX
Q
;
HELPTX ;EP
;---> CREATES DIR ARRAY FOR DIR. REQUIRED VARIABLES: BWTAB,BWLINL.
N I,T,X S T="" F I=1:1:BWTAB S T=T_" "
F I=1:1 S X=$T(@BWLINL+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 BW1,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,"-"),BW1(Y1)=Y
S N=0,X=""
F S N=$O(BW1(N)) Q:'N S X=X_BW1(N)_","
S:$E(X,$L(X))="," X=$E(X,1,($L(X)-1))
Q
BWRPPCD ;IHS/ANMC/MWR - REPORT: PROCEDURES STATISTICS;15-Feb-2003 22:09;PLS
+1 ;;2.0;WOMEN'S HEALTH;**6,8**;MAY 16, 1996
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; CALLED BY OPTION: "BW PRINT PROCEDURE STATS".
+4 ;
+5 DO SETVARS^BWUTL5
SET BWPOP=0
KILL BWRES
+6 DO TITLE^BWUTL5("PROCEDURE STATISTICS REPORT")
+7 DO DATES
IF BWPOP
GOTO EXIT
+8 DO SELECT
IF BWPOP
GOTO EXIT
+9 ;IHS/CMI/LAB - added current community screen
DO CURCOM
IF BWPOP
GOTO EXIT
+10 DO BYAGE(.BWAGRG,.BWPOP)
IF BWPOP
GOTO EXIT
+11 DO DEVICE
IF BWPOP
GOTO EXIT
+12 DO ^BWRPPCD2
+13 DO COPYGBL
+14 DO ^BWRPPCD1
+15 ;
EXIT ;EP
+1 DO KILLALL^BWUTL8
+2 QUIT
+3 ;
+4 ;
DATES ;EP
+1 ;---> ASK DATE RANGE. RETURN DATES IN BWBEGDT AND BWENDDT.
+2 DO ASKDATES^BWUTL3(.BWBEGDT,.BWENDDT,.BWPOP,"T-365","T")
+3 QUIT
+4 ;
SELECT ;EP
+1 DO SELECT^BWSELECT("Procedure Type",9002086.2,"BWARR","","",.BWPOP)
+2 QUIT
+3 ;
CURCOM ;
+1 ;IHS/CMI/LAB - added this subroutine to screen on current comm
+2 ;---> SELECT CASES FOR ONE OR MORE CURRENT COMMUNITY (OR ALL).
+3 ;---> DO NOT PROMPT FOR CURRENT COMMUNITY IF THIS IS A VA SITE.
+4 ;IHS/ANMC/MWR 11/20/96
IF $$AGENCY^BWUTL5(DUZ(2))'="i"
Begin DoDot:1
+5 ;IHS/ANMC/MWR 11/20/96
SET BWCC("ALL")=""
End DoDot:1
QUIT
+6 ;---> SELECT CURRENT COMMUNITY(S).
+7 DO TEXT2^BWRPSCR
KILL BWTAB,BWLINL
+8 ;D SELECT^BWSELECT("Current Community",9999999.05,"BWCC","","",.BWPOP)
+9 KILL BWCC
+10 SET DIR(0)="S^O:One particular Community;A:All Communities;S:Selected Set of Communities (Taxonomy)"
SET DIR("A")="List children who live in"
SET DIR("B")="O"
KILL DA
DO ^DIR
KILL DIR
+11 IF $DATA(DIRUT)
SET BWPOP=1
QUIT
+12 IF Y="A"
WRITE !!,"All communities will be included in the report.",!
SET BWCC("ALL")=""
QUIT
+13 IF Y="O"
Begin DoDot:1
+14 SET DIC="^AUTTCOM("
SET DIC(0)="AEMQ"
SET DIC("A")="Which COMMUNITY: "
DO ^DIC
KILL DIC
+15 IF Y=-1
QUIT
+16 SET BWCC($PIECE(^AUTTCOM(+Y,0),U))=""
End DoDot:1
IF $DATA(BWCC)
QUIT
IF 1
+17 SET X="COMMUNITY"
SET DIC="^AMQQ(5,"
SET DIC(0)="FM"
SET DIC("S")="I $P(^(0),U,14)"
DO ^DIC
KILL DIC,DA
IF Y=-1
WRITE "OOPS - QMAN NOT CURRENT - QUITTING"
GOTO CURCOM
+18 DO ^AMQQGTX0(+Y,"BWCC(")
+19 IF '$DATA(BWCC)
GOTO CURCOM
+20 IF $DATA(BWCC("*"))
SET BWCC("ALL")=""
+21 QUIT
+22 ;
BYAGE(BWAGRG,BWPOP) ;EP
+1 ;---> RETURN AGE RANGE IN BWAGRG.
+2 NEW DIR,DIRUT,Y
SET BWPOP=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 BWPOP=1
+8 ;---> IF NOT DISPLAYING BY AGE GROUP, SET BWAGRG (AGE RANGE)=1, QUIT.
+9 IF 'Y
SET BWAGRG=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(^BWAGDF(DUZ,0))
SET DIR("B")=$PIECE(^(0),U,2)
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)
SET BWPOP=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 ;---> BWAGRG=SELECTED AGE RANGE(S).
+17 SET BWAGRG=Y
+18 DO DIC^BWFMAN(9002086.72,"L",.Y,"","","","`"_DUZ)
+19 IF Y<0
QUIT
+20 DO DIE^BWFMAN(9002086.72,".02////"_BWAGRG,+Y,.BWPOP,1)
+21 QUIT
+22 ;
DEVICE ;EP
+1 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
+2 SET ZTRTN="DEQUEUE^BWRPPCD"
+3 FOR BWSV="AGRG","BEGDT","ENDDT"
Begin DoDot:1
+4 IF $DATA(@("BW"_BWSV))
SET ZTSAVE("BW"_BWSV)=""
End DoDot:1
+5 ;---> SAVE PROCEDURES ARRAY.
+6 IF $DATA(BWARR)
NEW N
SET N=0
FOR
SET N=$ORDER(BWARR(N))
IF N=""
QUIT
Begin DoDot:1
+7 SET ZTSAVE("BWARR("""_N_""")")=""
End DoDot:1
+8 DO ZIS^BWUTL2(.BWPOP,1)
+9 QUIT
+10 ;
COPYGBL ;EP
+1 ;---> COPY BWRES("R") TO BWAR( TO MAKE IT FLAT.
+2 NEW I,M,N
KILL BWAR
+3 SET N=0
SET I=0
+4 FOR
SET N=$ORDER(BWRES("R",N))
IF N=""
QUIT
Begin DoDot:1
+5 SET M=0
+6 FOR
SET M=$ORDER(BWRES("R",N,M))
IF M=""
QUIT
Begin DoDot:2
+7 SET I=I+1
SET BWAR(I)=BWRES("R",N,M)
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
+10 ;
DEQUEUE ;EP
+1 ;---> TASKMAN QUEUE OF PRINTOUT.
+2 DO SETVARS^BWUTL5
DO ^BWRPPCD2
DO COPYGBL
DO ^BWRPPCD1
DO EXIT
+3 QUIT
+4 ;
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 BWTAB=5
SET BWLINL="HELP1"
DO HELPTX
+7 QUIT
+8 ;
HELP2 ;EP
+1 ;;Enter each age range you which 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 BWTAB=5
SET BWLINL="HELP2"
DO HELPTX
+10 QUIT
+11 ;
HELPTX ;EP
+1 ;---> CREATES DIR ARRAY FOR DIR. REQUIRED VARIABLES: BWTAB,BWLINL.
+2 NEW I,T,X
SET T=""
FOR I=1:1:BWTAB
SET T=T_" "
+3 FOR I=1:1
SET X=$TEXT(@BWLINL+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 BW1,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 BW1(Y1)=Y
+18 SET N=0
SET X=""
+19 FOR
SET N=$ORDER(BW1(N))
IF 'N
QUIT
SET X=X_BW1(N)_","
+20 IF $EXTRACT(X,$LENGTH(X))=","
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+21 QUIT
