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