Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BWRPPCD

BWRPPCD.m

Go to the documentation of this file. 
  1. BWRPPCD ;IHS/ANMC/MWR - REPORT: PROCEDURES STATISTICS;15-Feb-2003 22:09;PLS
  1.  ;;2.0;WOMEN'S HEALTH;**6,8**;MAY 16, 1996
  1.  ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
  1.  ;;  CALLED BY OPTION: "BW PRINT PROCEDURE STATS".
  1.  ;
  1.  D SETVARS^BWUTL5 S BWPOP=0 K BWRES
  1.  D TITLE^BWUTL5("PROCEDURE STATISTICS REPORT")
  1.  D DATES                  G:BWPOP EXIT
  1.  D SELECT                 G:BWPOP EXIT
  1.  D CURCOM                 G:BWPOP EXIT ;IHS/CMI/LAB - added current community screen
  1.  D BYAGE(.BWAGRG,.BWPOP)  G:BWPOP EXIT
  1.  D DEVICE                 G:BWPOP EXIT
  1.  D ^BWRPPCD2
  1.  D COPYGBL
  1.  D ^BWRPPCD1
  1.  ;
  1. EXIT ;EP
  1.  D KILLALL^BWUTL8
  1.  Q
  1.  ;
  1.  ;
  1. DATES ;EP
  1.  ;---> ASK DATE RANGE.  RETURN DATES IN BWBEGDT AND BWENDDT.
  1.  D ASKDATES^BWUTL3(.BWBEGDT,.BWENDDT,.BWPOP,"T-365","T")
  1.  Q
  1.  ;
  1. SELECT ;EP
  1.  D SELECT^BWSELECT("Procedure Type",9002086.2,"BWARR","","",.BWPOP)
  1.  Q
  1.  ;
  1. CURCOM ;
  1.  ;IHS/CMI/LAB - added this subroutine to screen on current comm
  1.  ;---> SELECT CASES FOR ONE OR MORE CURRENT COMMUNITY (OR ALL).
  1.  ;---> DO NOT PROMPT FOR CURRENT COMMUNITY IF THIS IS A VA SITE.
  1.  I $$AGENCY^BWUTL5(DUZ(2))'="i" D  Q  ;IHS/ANMC/MWR 11/20/96
  1.  .S BWCC("ALL")=""                    ;IHS/ANMC/MWR 11/20/96
  1.  ;---> SELECT CURRENT COMMUNITY(S).
  1.  D TEXT2^BWRPSCR K BWTAB,BWLINL
  1.  ;D SELECT^BWSELECT("Current Community",9999999.05,"BWCC","","",.BWPOP)
  1.  K BWCC
  1.  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
  1.  I $D(DIRUT) S BWPOP=1 Q
  1.  I Y="A" W !!,"All communities will be included in the report.",! S BWCC("ALL")="" Q
  1.  I Y="O" D  Q:$D(BWCC)  I 1
  1.  .S DIC="^AUTTCOM(",DIC(0)="AEMQ",DIC("A")="Which COMMUNITY: " D ^DIC K DIC
  1.  .Q:Y=-1
  1.  .S BWCC($P(^AUTTCOM(+Y,0),U))=""
  1.  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
  1.  D ^AMQQGTX0(+Y,"BWCC(")
  1.  I '$D(BWCC) G CURCOM
  1.  I $D(BWCC("*")) S BWCC("ALL")=""
  1.  Q
  1.  ;
  1. BYAGE(BWAGRG,BWPOP) ;EP
  1.  ;---> RETURN AGE RANGE IN BWAGRG.
  1.  N DIR,DIRUT,Y S BWPOP=0
  1.  W !!?3,"Do you wish to display statistics by age group?"
  1.  S DIR(0)="Y",DIR("B")="YES" D HELP1
  1.  S DIR("A")="   Enter Yes or No"
  1.  D ^DIR K DIR W !
  1.  S:$D(DIRUT) BWPOP=1
  1.  ;---> IF NOT DISPLAYING BY AGE GROUP, SET BWAGRG (AGE RANGE)=1, QUIT.
  1.  I 'Y S BWAGRG=1 Q
  1. BYAGE1 ;
  1.  W !?5,"Enter the age ranges you wish to select for in the form of:"
  1.  W !?5,"  15-29,30-39,40-105"
  1.  W !?5,"Use a dash ""-"" to separate the limits of a range,"
  1.  W !?5,"use a comma to separate the different ranges."
  1.  W !!?5,"NOTE: Patient ages will reflect the age they were on the"
  1.  W !?5,"      dates of their procedures.  Patient ages will NOT"
  1.  W !?5,"      necessarily be their ages today.",!
  1.  K DIR D HELP2
  1.  S DIR(0)="FOA",DIR("A")="     Enter age ranges: "
  1.  S:$D(^BWAGDF(DUZ,0)) DIR("B")=$P(^(0),U,2)
  1.  D ^DIR K DIR
  1.  I $D(DIRUT) S BWPOP=1 Q
  1.  D CHECK(.Y)
  1.  I Y="" D  G BYAGE1
  1.  .W !!?5,"* INVALID AGE RANGE.  Please begin again. (Enter ? for help.)"
  1.  ;---> BWAGRG=SELECTED AGE RANGE(S).
  1.  S BWAGRG=Y
  1.  D DIC^BWFMAN(9002086.72,"L",.Y,"","","","`"_DUZ)
  1.  Q:Y<0
  1.  D DIE^BWFMAN(9002086.72,".02////"_BWAGRG,+Y,.BWPOP,1)
  1.  Q
  1.  ;
  1. DEVICE ;EP
  1.  ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
  1.  S ZTRTN="DEQUEUE^BWRPPCD"
  1.  F BWSV="AGRG","BEGDT","ENDDT" D
  1.  .I $D(@("BW"_BWSV)) S ZTSAVE("BW"_BWSV)=""
  1.  ;---> SAVE PROCEDURES ARRAY.
  1.  I $D(BWARR) N N S N=0 F  S N=$O(BWARR(N)) Q:N=""  D
  1.  .S ZTSAVE("BWARR("""_N_""")")=""
  1.  D ZIS^BWUTL2(.BWPOP,1)
  1.  Q
  1.  ;
  1. COPYGBL ;EP
  1.  ;---> COPY BWRES("R") TO BWAR( TO MAKE IT FLAT.
  1.  N I,M,N K BWAR
  1.  S N=0,I=0
  1.  F  S N=$O(BWRES("R",N)) Q:N=""  D
  1.  .S M=0
  1.  .F  S M=$O(BWRES("R",N,M)) Q:M=""  D
  1.  ..S I=I+1,BWAR(I)=BWRES("R",N,M)
  1.  Q
  1.  ;
  1.  ;
  1. DEQUEUE ;EP
  1.  ;---> TASKMAN QUEUE OF PRINTOUT.
  1.  D SETVARS^BWUTL5,^BWRPPCD2,COPYGBL,^BWRPPCD1,EXIT
  1.  Q
  1.  ;
  1. HELP1 ;EP
  1.  ;;Answer "YES" to display statistics by age group.  If you choose
  1.  ;;to display by age group, you will be given the opportunity to
  1.  ;;select the age ranges.  For example, you might choose to display
  1.  ;;from ages 15-40,41-65,65-99.
  1.  ;;Answer "NO" to display statistics without grouping by age.
  1.  S BWTAB=5,BWLINL="HELP1" D HELPTX
  1.  Q
  1.  ;
  1. HELP2 ;EP
  1.  ;;Enter each age range you which to report on by entering the
  1.  ;;earlier age-dash-older age.  For example, 20-29 would report
  1.  ;;on all patients between the ages of 20 and 29 inclusive.
  1.  ;;You may select as many age ranges as you wish.  Age ranges must
  1.  ;;be separated by commas.  For example: 15-19,20-29,30-39
  1.  ;;To select only one age, simply enter that age, with no dashes,
  1.  ;;for example, 30 would report only on women who were 30 years
  1.  ;;of age.
  1.  S BWTAB=5,BWLINL="HELP2" D HELPTX
  1.  Q
  1.  ;
  1. HELPTX ;EP
  1.  ;---> CREATES DIR ARRAY FOR DIR.  REQUIRED VARIABLES: BWTAB,BWLINL.
  1.  N I,T,X S T="" F I=1:1:BWTAB S T=T_" "
  1.  F I=1:1 S X=$T(@BWLINL+I) Q:X'[";;"  S DIR("?",I)=T_$P(X,";;",2)
  1.  S DIR("?")=DIR("?",I-1) K DIR("?",I-1)
  1.  Q
  1.  ;
  1. CHECK(X) ;EP
  1.  ;---> CHECK SYNTAX OF AGE RANGE STRING.
  1.  ;---> IF X=ONE AGE ONLY, SET IT IN THE FORM X-X AND QUIT.
  1.  I X?1N.N S X=X_"-"_X Q
  1.  ;
  1.  N BW1,FAIL,I,Y,Y1,Y2
  1.  S FAIL=0
  1.  ;---> CHECK EACH RANGE.
  1.  F I=1:1:$L(X,",") S Y=$P(X,",",I) D  Q:FAIL
  1.  .S Y1=$P(Y,"-"),Y2=$P(Y,"-",2)
  1.  .;---> EACH END OF EACH RANGE SHOULD BE A NUMBER.
  1.  .I (Y1'?1N.N)!(Y2'?1N.N) S FAIL=1 Q
  1.  .;---> THE LOWER NUMBER SHOULD BE FIRST.
  1.  .I Y2<Y1 S FAIL=1
  1.  I FAIL S X="" Q
  1.  ;
  1.  ;---> MAKE SURE ORDER IS FROM LOWEST (YOUNGEST) TO HIGHEST (OLDEST).
  1.  F I=1:1:$L(X,",") S Y=$P(X,",",I),Y1=$P(Y,"-"),BW1(Y1)=Y
  1.  S N=0,X=""
  1.  F  S N=$O(BW1(N)) Q:'N  S X=X_BW1(N)_","
  1.  S:$E(X,$L(X))="," X=$E(X,1,($L(X)-1))
  1.  Q