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

BWRPSNP.m

Go to the documentation of this file. 
  1. BWRPSNP ;IHS/ANMC/MWR - REPORT: SNAPSHOT OF PROGRAM ;15-Feb-2003 22:10;PLS
  1.  ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
  1.  ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
  1.  ;;  CALLED BY OPTION: "BW PRINT SNAPSHOT" TO DISPLAY FROM 1/1 CURRENT
  1.  ;;  YEAR TO PRESENT #PATIENTS, #PAPS, #MAMS, #DELINQUENT NEEDS, ETC.
  1.  ;
  1.  D SETVARS^BWUTL5 S BWFAC=DUZ(2)
  1.  N A,B,C,D,E,F,G,H,J,K,L,M,N,P,Q,R,S,X,Y
  1.  D TITLE^BWUTL5("PROGRAM SNAPSHOT")
  1.  D ASKSAVE G:BWPOP EXIT
  1.  D DEVICE  G:BWPOP EXIT
  1.  D GATHER
  1.  D:BWA STORE
  1.  D ^BWRPSNP1
  1.  ;
  1. EXIT ;EP
  1.  D KILLALL^BWUTL8
  1.  Q
  1.  ;
  1. DEVICE ;EP
  1.  ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
  1.  S ZTRTN="DEQUEUE^BWRPSNP"
  1.  F BWSV="A","FAC" D
  1.  .I $D(@("BW"_BWSV)) S ZTSAVE("BW"_BWSV)=""
  1.  D ZIS^BWUTL2(.BWPOP,1,"HOME")
  1.  Q
  1.  ;
  1. ASKSAVE ;EP
  1.  ;---> ASK IF THIS REPORT SHOULD BE SAVED FOR LATER RETRIEVAL.
  1.  N DIR,DIRUT,Y
  1.  W !!?3,"Should today's Snapshot be stored for later retrieval and"
  1.  W " comparisons?"
  1.  S DIR(0)="Y",DIR("A")="   Enter Yes or No",DIR("B")="NO"
  1.  S BWA=0 D HELP1
  1.  D ^DIR K DIR W !
  1.  S:$D(DIRUT) BWPOP=1
  1.  S:Y BWA=1
  1.  Q
  1.  ;
  1. DEQUEUE ;EP
  1.  ;---> QUEUED REPORT
  1.  N A,B,C,D,E,F,G,H,J,K,L,M,N,P,Q,R,S,X,Y
  1.  D SETVARS^BWUTL5,GATHER,STORE,^BWRPSNP1,EXIT
  1.  Q
  1.  ;
  1. STORE ;EP
  1.  ;---> STORE REPORT DATA IN FILE #9002086.71.
  1.  Q:'BWA
  1.  N BWDR,BWI,DA,DIC,DIE,X,Y
  1.  S BWDR=".02////"_BWFAC,Y=.02
  1.  F BWI=A,B,C,D,E,F,G,H,S,J,K,L,P,Q,R D
  1.  .S Y=Y+.01,BWDR=BWDR_";"_Y_"////"_BWI
  1.  N A,B,C,D,E,F,G,H,S,J,K,L,P,Q,R D
  1.  .D DIC^BWFMAN(9002086.71,"ML",.Y,"","","",BWDT)
  1.  .Q:Y<0
  1.  .D DIE^BWFMAN(9002086.71,BWDR,+Y)
  1.  Q
  1.  ;
  1.  ;
  1. GATHER ;EP
  1.  ;---> GATHER DATA
  1.  S (A,B,C,D,E,F,G,H,J,K,L,M,N,P,Q,R,S)=0
  1.  ;---> USE BWDT SO THAT THE DATE WON'T CHANGE IF RUN SPANS MIDNIGHT.
  1.  D SETVARS^BWUTL5 S BWDT=DT
  1.  ;
  1.  ;---> PATIENT DATA
  1.  F  S N=$O(^BWP(N)) Q:'N  S Y=^BWP(N,0) D
  1.  .;---> QUIT IF PATIENT IS NOT ACTIVE.
  1.  .Q:$P(Y,U,24)
  1.  .;---> QUIT IF PATIENT IS DECEASED.
  1.  .Q:$$DECEASED^BWUTL1($P(Y,U))
  1.  .;---> TOTAL WOMEN IN REGISTER.
  1.  .S A=A+1
  1.  .;---> WOMEN PREGNANT.
  1.  .I $P(Y,U,13)&($P(Y,U,14)>BWDT) S B=B+1
  1.  .;---> DES DAUGHTERS.
  1.  .S:$P(Y,U,15) C=C+1
  1.  .;---> WOMEN WITH CERVICAL TX NEEDS NOT SPECIFIED OR NOT DATED.
  1.  .I 5[$P(Y,U,11)!('$P(Y,U,12)) S D=D+1
  1.  .;---> IF DATE DUE=NULL IT WAS COUNTED LINE ABOVE, SO DON'T COUNT
  1.  .;---> IT IN THE LINE BELOW: +$P(Y,U,19).
  1.  .;---> WOMEN WITH CERVICAL TX NEEDS SPECIFIED AND PAST DUE.
  1.  .I 5'[$P(Y,U,11)&($P(Y,U,12)<BWDT)&(+$P(Y,U,12)) S E=E+1
  1.  .;---> WOMEN WITH BREAST TX NEEDS NOT SPECIFIED OR NOT DATED.
  1.  .I 8[$P(Y,U,18)!('$P(Y,U,19)) S F=F+1
  1.  .;---> WOMEN WITH BREAST TX NEEDS SPECIFIED AND PAST DUE.
  1.  .I 8'[$P(Y,U,18)&($P(Y,U,19)<BWDT)&(+$P(Y,U,19)) S G=G+1
  1.  ;
  1.  ;---> PROCEDURE DATA
  1.  S N=0
  1.  F  S N=$O(^BWPCD("S","o",N)) Q:'N  S Y=^BWPCD(N,0) D
  1.  .Q:"o"'[$P(Y,U,14)
  1.  .Q:$P(Y,U,5)=8
  1.  .S H=H+1 S:$P(Y,U,13)<BWDT S=S+1
  1.  ;
  1.  ;---> TOTAL PAPS, CBES, AND MAMS FOR THIS YEAR (SINCE JAN 1).
  1.  S N=$E(BWDT,1,3)_"0000",BWENDDT1=BWDT+.9999
  1.  F  S N=$O(^BWPCD("D",N)) Q:'N!(N>BWENDDT1)  D
  1.  .S M=0
  1.  .F  S M=$O(^BWPCD("D",N,M)) Q:'M  S Y=^BWPCD(M,0) D
  1.  ..;---> BELOW IS HARD CODED FOR IENS IN ^BWPN (PAP, CBE, OR MAM) AND
  1.  ..;---> ^BWDIAG (ERROR/DISREGARD).  COULD BE MORE ROBUST BY LOOKING
  1.  ..;---> AT #.10 FIELD OF ^BWPN AND #.23 FIELD OF ^BWDIAG.
  1.  ..Q:$P(Y,U,5)=8
  1.  ..I $P(Y,U,4)=1 S P=P+1 Q                                    ;---> PAP
  1.  ..I $P(Y,U,4)=25!($P(Y,U,4)=26)!($P(Y,U,4)=28) S Q=Q+1 Q     ;---> MAM
  1.  ..I $P(Y,U,4)=27 S R=R+1                                     ;---> CBE
  1.  ;
  1.  ;---> NOTIFICATION DATA
  1.  S N=0
  1.  F  S N=$O(^BWNOT("AOPEN",N)) Q:'N  D
  1.  .S M=0
  1.  .F  S M=$O(^BWNOT("AOPEN",N,M)) Q:'M  D
  1.  ..I '$D(^BWNOT(M,0)) K ^BWNOT("AOPEN",N,M) Q
  1.  ..S Y=^BWNOT(M,0)
  1.  ..S:$P(Y,U,14)="o" J=J+1
  1.  ..S:$P(Y,U,14)="o"&($P(Y,U,13)<BWDT) K=K+1
  1.  ;---> LETTERS QUEUED
  1.  S N=0 F  S N=$O(^BWNOT("APRT",N)) Q:'N  D
  1.  .S M=0 F  S M=$O(^BWNOT("APRT",N,M)) Q:'M  S L=L+1
  1.  Q
  1.  ;
  1.  ;
  1. HELP1 ;EP
  1.  ;;Answer "YES" to store the results of today's snapshot after they
  1.  ;;have been printed out.  These results can then be retrieved in the
  1.  ;;future (by calling up today's date) and compared to other Snapshots
  1.  ;;in order to look at the trends and progress of your program over
  1.  ;;time. (Note: If a previous snapshot for today has been run, it will
  1.  ;;be overwritten by this or any later run today.)
  1.  ;;
  1.  ;;Answer "NO" to simply print today's Snapshot without storing it.
  1.  S BWTAB=5,BWLINL="HELP1" D HELPTX
  1.  Q
  1.  ;
  1. HELPTX ;EP
  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