BWRPSCR1 ;IHS/ANMC/MWR - WOMEN'S HEALTH PCC LINK [ 09/07/99 7:28 AM ];15-Feb-2003 22:37;PLS
;;2.0;WOMEN'S HEALTH;**6,8**;MAY 16, 1996
;patch 6 modified current community screen
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; THIS REPORT WILL DISPLAY SCREENING RATES FOR PAPS & MAMS.
;; ENTRY POINTS CALLED BY BWRPSCR.
;
;
DATA ;EP
;---> SORT AND STORE ARRAY IN ^TMP("BW",$J
K BWTMP,^TMP("BW",$J)
;---> BWBEGDT1=ONE SECOND BEFORE BEGIN DATE.
;---> BWENDDT1=THE LAST SECOND OF END DATE.
S BWBEGDT1=BWBEGDT-.0001,BWENDDT1=BWENDDT+.9999
;
S BWDATE=BWBEGDT1
F S BWDATE=$O(^BWPCD("D",BWDATE)) Q:'BWDATE!(BWDATE>BWENDDT1) D
.S BWIEN=0
.F S BWIEN=$O(^BWPCD("D",BWDATE,BWIEN)) Q:'BWIEN D
..S Y=^BWPCD(BWIEN,0)
..S BWDFN=$P(Y,U,2),BWPCDN=$P(Y,U,4),BWRES=$P(Y,U,5)
..;
..;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
..Q:BWRES=8
..;
..;---> QUIT IF NEITHER A PAP (IEN=1) NOR A SCREENING MAM (IEN=28).
..Q:((BWPCDN'=1)&(BWPCDN'=28))
..;
..;---> QUIT IS PATIENT IS NOT WITHIN AGE RANGE.
..S BWAGE=+$$AGE^BWUTL1(BWDFN)
..I BWAGRG'=1 Q:((BWAGE<$P(BWAGRG,"-"))!(BWAGE>$P(BWAGRG,"-",2)))
..;
..;---> QUIT IF NOT SELECTING ALL CURRENT COMMUNITIES AND IF THIS
..;---> IS NOT ONE OF THE SELECETED.
..I '$D(BWCC("ALL")) S X=$P($G(^AUPNPAT(BWDFN,11)),U,18) Q:X="" Q:'$D(BWCC(X))
..;
..;---> GET VALUE OF RESULT: 0=NORMAL, 1=ABNORMAL, 2=NO RESULT
..S BWNORM=$$NORMAL^BWUTL4(BWRES) S:BWNORM=2 BWNORM=0
..;
..S ^TMP("BW",$J,BWDFN,BWNORM,BWPCDN,BWIEN)=""
;
;---> NOW COLLATE DATA FROM ^TMP ARRAY INTO LOCAL BWTMP REPORT ARRAY.
;---> FIRST, SEED LOCAL ARRAY WITH ZEROS.
F M=1,28 D
.N I F I=1:1:9 S BWTMP("RES",M,I)=0
;
;---> COLLATE DATA.
S N=0
F S N=$O(^TMP("BW",$J,N)) Q:'N D
.F M=1,28 D
..Q:$D(^TMP("BW",$J,N,1,M))
..S P=0,Q=0
..F S P=$O(^TMP("BW",$J,N,0,M,P)) Q:'P S Q=Q+1
..Q:'Q
..I '$D(BWTMP("RES",M,Q)) S BWTMP("RES",M,Q)=1 Q
..S BWTMP("RES",M,Q)=BWTMP("RES",M,Q)+1
;
;---> STORE ALL NODES >9 IN THE 9+ NODE.
F M=1,28 D
.S Q=9
.F S Q=$O(BWTMP("RES",M,Q)) Q:'Q D
..S BWTMP("RES",M,9)=BWTMP("RES",M,9)+BWTMP("RES",M,Q)
..K BWTMP("RES",M,Q)
;
;---> FIGURE PERCENTAGES OF WOMEN AND STORE IN ARRAY.
F M=1,28 D
.S BWTOT=0
.F Q=1:1:9 S BWTOT=BWTOT+BWTMP("RES",M,Q)
.S:'BWTOT BWTOT=1
.F Q=1:1:9 S $P(BWTMP("RES",M,Q),U,2)=$J((+BWTMP("RES",M,Q)/BWTOT),0,2)
;
;---> BUILD DISPLAY ARRAY.
N BWNODE K ^TMP("BW",$J)
;
;---> PAPS SUBHEADER LINE.
S BWNODE=$$S(32)_"SCREENING PAPS"
D WRITE(1,BWNODE)
S BWNODE=$$S(31)_"----------------"
D WRITE(2,BWNODE)
S BWNODE=" # of PAPs: 1 2 3 4 5"
S BWNODE=BWNODE_" 6 7 8 9+"
D WRITE(4,BWNODE)
S BWNODE=" ----------- ------ ------ ------ ------ ------"
S BWNODE=BWNODE_" ------ ------ ------ ------"
D WRITE(5,BWNODE)
;
;---> PAPS NUMBER OF WOMEN DATA LINE.
S BWNODE=" # of Women: "
F Q=1:1:9 S BWNODE=BWNODE_$J($P(BWTMP("RES",1,Q),U),7)
D WRITE(6,BWNODE)
S BWNODE=" % of Women: "
F Q=1:1:9 S BWNODE=BWNODE_$J(($P(BWTMP("RES",1,Q),U,2)*100),6)_"%"
D WRITE(7,BWNODE)
;
;---> LINE FEEDS BETWEEN PAPS AND MAMS.
S BWNODE="" D WRITE(8,BWNODE) S BWNODE="" D WRITE(9,BWNODE)
;
;---> MAMS SUBHEADER LINE.
S BWNODE=$$S(32)_"SCREENING MAMS"
D WRITE(10,BWNODE)
S BWNODE=$$S(31)_"----------------"
D WRITE(11,BWNODE)
S BWNODE=" # of MAMs: 1 2 3 4 5"
S BWNODE=BWNODE_" 6 7 8 9+"
D WRITE(13,BWNODE)
S BWNODE=" ----------- ------ ------ ------ ------ ------"
S BWNODE=BWNODE_" ------ ------ ------ ------"
D WRITE(14,BWNODE)
;
;---> PAPS NUMBER OF WOMEN DATA LINE.
S BWNODE=" # of Women: "
F Q=1:1:9 S BWNODE=BWNODE_$J($P(BWTMP("RES",28,Q),U),7)
D WRITE(15,BWNODE)
S BWNODE=" % of Women: "
F Q=1:1:9 S BWNODE=BWNODE_$J(($P(BWTMP("RES",28,Q),U,2)*100),6)_"%"
D WRITE(16,BWNODE)
Q
;
WRITE(I,Y) ;EP
S ^TMP("BW",$J,I,0)=Y
Q
;
S(S) ;EP
;---> SPACES.
Q $$S^BWUTL7($G(S))
;
;
AGERNG(BWAGRG,BWPOP) ;EP
;---> ASK AGE RANGE.
;---> RETURN AGE RANGE IN BWAGRG.
N DIR,DIRUT,Y S BWPOP=0
W !!?3,"Do you wish to limit this report to an age range?"
S DIR(0)="Y",DIR("B")="NO" D HELP1
S DIR("A")=" Enter Yes or No"
D ^DIR K DIR W !
S:$D(DIRUT) BWPOP=1
;---> IF NOT DISPLAYING BY AGE RANGE, SET BWAGRG (AGE RANGE)=1, QUIT.
I 'Y S BWAGRG=1 Q
BYAGE1 ;
W !?5,"Enter the age range you wish to select in the form of: 40-75"
W !?5,"Use a dash ""-"" to separate the limits of the range."
W !?5,"To select only one age, simply enter that age, with no dash."
W !?5,"(NOTE: Patient ages will reflect the age they are today.)",!
K DIR
S DIR(0)="FOA",DIR("A")=" Enter age range: "
S:$D(^BWAGDF(DUZ,0)) DIR("B")=$P(^(0),U,3)
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."
;---> BWAGRG=SELECTED AGE RANGE(S).
S BWAGRG=Y
D DIC^BWFMAN(9002086.72,"L",.Y,"","","","`"_DUZ)
Q:Y<0
D DIE^BWFMAN(9002086.72,".03////"_BWAGRG,+Y,.BWPOP,1)
Q
;
HELP1 ;EP
;;Answer "YES" to display screening rates for a specific age range.
;;If you choose to display for an age range, you will be given the
;;opportunity to select the age range. For example, you might choose
;;to display from ages 50-75.
;;Answer "NO" to display screening rates for all ages.
S BWTAB=5,BWLINL="HELP1" D HELPTX
Q
;
PRINTX ;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'[";;" W !,T,$P(X,";;",2)
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 FAIL,I,Y1,Y2
S FAIL=0
;---> CHECK EACH RANGE.
S Y1=$P(X,"-"),Y2=$P(X,"-",2)
;---> EACH END OF EACH RANGE SHOULD BE A NUMBER.
I (Y1'?1N.N)!(Y2'?1N.N) S X="" Q
;---> THE LOWER NUMBER SHOULD BE FIRST.
I Y2<Y1 S FAIL=1
I FAIL S X="" Q
Q
BWRPSCR1 ;IHS/ANMC/MWR - WOMEN'S HEALTH PCC LINK [ 09/07/99 7:28 AM ];15-Feb-2003 22:37;PLS
+1 ;;2.0;WOMEN'S HEALTH;**6,8**;MAY 16, 1996
+2 ;patch 6 modified current community screen
+3 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+4 ;; THIS REPORT WILL DISPLAY SCREENING RATES FOR PAPS & MAMS.
+5 ;; ENTRY POINTS CALLED BY BWRPSCR.
+6 ;
+7 ;
DATA ;EP
+1 ;---> SORT AND STORE ARRAY IN ^TMP("BW",$J
+2 KILL BWTMP,^TMP("BW",$JOB)
+3 ;---> BWBEGDT1=ONE SECOND BEFORE BEGIN DATE.
+4 ;---> BWENDDT1=THE LAST SECOND OF END DATE.
+5 SET BWBEGDT1=BWBEGDT-.0001
SET BWENDDT1=BWENDDT+.9999
+6 ;
+7 SET BWDATE=BWBEGDT1
+8 FOR
SET BWDATE=$ORDER(^BWPCD("D",BWDATE))
IF 'BWDATE!(BWDATE>BWENDDT1)
QUIT
Begin DoDot:1
+9 SET BWIEN=0
+10 FOR
SET BWIEN=$ORDER(^BWPCD("D",BWDATE,BWIEN))
IF 'BWIEN
QUIT
Begin DoDot:2
+11 SET Y=^BWPCD(BWIEN,0)
+12 SET BWDFN=$PIECE(Y,U,2)
SET BWPCDN=$PIECE(Y,U,4)
SET BWRES=$PIECE(Y,U,5)
+13 ;
+14 ;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
+15 IF BWRES=8
QUIT
+16 ;
+17 ;---> QUIT IF NEITHER A PAP (IEN=1) NOR A SCREENING MAM (IEN=28).
+18 IF ((BWPCDN'=1)&(BWPCDN'=28))
QUIT
+19 ;
+20 ;---> QUIT IS PATIENT IS NOT WITHIN AGE RANGE.
+21 SET BWAGE=+$$AGE^BWUTL1(BWDFN)
+22 IF BWAGRG'=1
IF ((BWAGE<$PIECE(BWAGRG,"-"))!(BWAGE>$PIECE(BWAGRG,"-",2)))
QUIT
+23 ;
+24 ;---> QUIT IF NOT SELECTING ALL CURRENT COMMUNITIES AND IF THIS
+25 ;---> IS NOT ONE OF THE SELECETED.
+26 IF '$DATA(BWCC("ALL"))
SET X=$PIECE($GET(^AUPNPAT(BWDFN,11)),U,18)
IF X=""
QUIT
IF '$DATA(BWCC(X))
QUIT
+27 ;
+28 ;---> GET VALUE OF RESULT: 0=NORMAL, 1=ABNORMAL, 2=NO RESULT
+29 SET BWNORM=$$NORMAL^BWUTL4(BWRES)
IF BWNORM=2
SET BWNORM=0
+30 ;
+31 SET ^TMP("BW",$JOB,BWDFN,BWNORM,BWPCDN,BWIEN)=""
End DoDot:2
End DoDot:1
+32 ;
+33 ;---> NOW COLLATE DATA FROM ^TMP ARRAY INTO LOCAL BWTMP REPORT ARRAY.
+34 ;---> FIRST, SEED LOCAL ARRAY WITH ZEROS.
+35 FOR M=1,28
Begin DoDot:1
+36 NEW I
FOR I=1:1:9
SET BWTMP("RES",M,I)=0
End DoDot:1
+37 ;
+38 ;---> COLLATE DATA.
+39 SET N=0
+40 FOR
SET N=$ORDER(^TMP("BW",$JOB,N))
IF 'N
QUIT
Begin DoDot:1
+41 FOR M=1,28
Begin DoDot:2
+42 IF $DATA(^TMP("BW",$JOB,N,1,M))
QUIT
+43 SET P=0
SET Q=0
+44 FOR
SET P=$ORDER(^TMP("BW",$JOB,N,0,M,P))
IF 'P
QUIT
SET Q=Q+1
+45 IF 'Q
QUIT
+46 IF '$DATA(BWTMP("RES",M,Q))
SET BWTMP("RES",M,Q)=1
QUIT
+47 SET BWTMP("RES",M,Q)=BWTMP("RES",M,Q)+1
End DoDot:2
End DoDot:1
+48 ;
+49 ;---> STORE ALL NODES >9 IN THE 9+ NODE.
+50 FOR M=1,28
Begin DoDot:1
+51 SET Q=9
+52 FOR
SET Q=$ORDER(BWTMP("RES",M,Q))
IF 'Q
QUIT
Begin DoDot:2
+53 SET BWTMP("RES",M,9)=BWTMP("RES",M,9)+BWTMP("RES",M,Q)
+54 KILL BWTMP("RES",M,Q)
End DoDot:2
End DoDot:1
+55 ;
+56 ;---> FIGURE PERCENTAGES OF WOMEN AND STORE IN ARRAY.
+57 FOR M=1,28
Begin DoDot:1
+58 SET BWTOT=0
+59 FOR Q=1:1:9
SET BWTOT=BWTOT+BWTMP("RES",M,Q)
+60 IF 'BWTOT
SET BWTOT=1
+61 FOR Q=1:1:9
SET $PIECE(BWTMP("RES",M,Q),U,2)=$JUSTIFY((+BWTMP("RES",M,Q)/BWTOT),0,2)
End DoDot:1
+62 ;
+63 ;---> BUILD DISPLAY ARRAY.
+64 NEW BWNODE
KILL ^TMP("BW",$JOB)
+65 ;
+66 ;---> PAPS SUBHEADER LINE.
+67 SET BWNODE=$$S(32)_"SCREENING PAPS"
+68 DO WRITE(1,BWNODE)
+69 SET BWNODE=$$S(31)_"----------------"
+70 DO WRITE(2,BWNODE)
+71 SET BWNODE=" # of PAPs: 1 2 3 4 5"
+72 SET BWNODE=BWNODE_" 6 7 8 9+"
+73 DO WRITE(4,BWNODE)
+74 SET BWNODE=" ----------- ------ ------ ------ ------ ------"
+75 SET BWNODE=BWNODE_" ------ ------ ------ ------"
+76 DO WRITE(5,BWNODE)
+77 ;
+78 ;---> PAPS NUMBER OF WOMEN DATA LINE.
+79 SET BWNODE=" # of Women: "
+80 FOR Q=1:1:9
SET BWNODE=BWNODE_$JUSTIFY($PIECE(BWTMP("RES",1,Q),U),7)
+81 DO WRITE(6,BWNODE)
+82 SET BWNODE=" % of Women: "
+83 FOR Q=1:1:9
SET BWNODE=BWNODE_$JUSTIFY(($PIECE(BWTMP("RES",1,Q),U,2)*100),6)_"%"
+84 DO WRITE(7,BWNODE)
+85 ;
+86 ;---> LINE FEEDS BETWEEN PAPS AND MAMS.
+87 SET BWNODE=""
DO WRITE(8,BWNODE)
SET BWNODE=""
DO WRITE(9,BWNODE)
+88 ;
+89 ;---> MAMS SUBHEADER LINE.
+90 SET BWNODE=$$S(32)_"SCREENING MAMS"
+91 DO WRITE(10,BWNODE)
+92 SET BWNODE=$$S(31)_"----------------"
+93 DO WRITE(11,BWNODE)
+94 SET BWNODE=" # of MAMs: 1 2 3 4 5"
+95 SET BWNODE=BWNODE_" 6 7 8 9+"
+96 DO WRITE(13,BWNODE)
+97 SET BWNODE=" ----------- ------ ------ ------ ------ ------"
+98 SET BWNODE=BWNODE_" ------ ------ ------ ------"
+99 DO WRITE(14,BWNODE)
+100 ;
+101 ;---> PAPS NUMBER OF WOMEN DATA LINE.
+102 SET BWNODE=" # of Women: "
+103 FOR Q=1:1:9
SET BWNODE=BWNODE_$JUSTIFY($PIECE(BWTMP("RES",28,Q),U),7)
+104 DO WRITE(15,BWNODE)
+105 SET BWNODE=" % of Women: "
+106 FOR Q=1:1:9
SET BWNODE=BWNODE_$JUSTIFY(($PIECE(BWTMP("RES",28,Q),U,2)*100),6)_"%"
+107 DO WRITE(16,BWNODE)
+108 QUIT
+109 ;
WRITE(I,Y) ;EP
+1 SET ^TMP("BW",$JOB,I,0)=Y
+2 QUIT
+3 ;
S(S) ;EP
+1 ;---> SPACES.
+2 QUIT $$S^BWUTL7($GET(S))
+3 ;
+4 ;
AGERNG(BWAGRG,BWPOP) ;EP
+1 ;---> ASK AGE RANGE.
+2 ;---> RETURN AGE RANGE IN BWAGRG.
+3 NEW DIR,DIRUT,Y
SET BWPOP=0
+4 WRITE !!?3,"Do you wish to limit this report to an age range?"
+5 SET DIR(0)="Y"
SET DIR("B")="NO"
DO HELP1
+6 SET DIR("A")=" Enter Yes or No"
+7 DO ^DIR
KILL DIR
WRITE !
+8 IF $DATA(DIRUT)
SET BWPOP=1
+9 ;---> IF NOT DISPLAYING BY AGE RANGE, SET BWAGRG (AGE RANGE)=1, QUIT.
+10 IF 'Y
SET BWAGRG=1
QUIT
BYAGE1 ;
+1 WRITE !?5,"Enter the age range you wish to select in the form of: 40-75"
+2 WRITE !?5,"Use a dash ""-"" to separate the limits of the range."
+3 WRITE !?5,"To select only one age, simply enter that age, with no dash."
+4 WRITE !?5,"(NOTE: Patient ages will reflect the age they are today.)",!
+5 KILL DIR
+6 SET DIR(0)="FOA"
SET DIR("A")=" Enter age range: "
+7 IF $DATA(^BWAGDF(DUZ,0))
SET DIR("B")=$PIECE(^(0),U,3)
+8 DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
SET BWPOP=1
QUIT
+10 DO CHECK(.Y)
+11 IF Y=""
Begin DoDot:1
+12 WRITE !!?5,"* INVALID AGE RANGE. Please begin again."
End DoDot:1
GOTO BYAGE1
+13 ;---> BWAGRG=SELECTED AGE RANGE(S).
+14 SET BWAGRG=Y
+15 DO DIC^BWFMAN(9002086.72,"L",.Y,"","","","`"_DUZ)
+16 IF Y<0
QUIT
+17 DO DIE^BWFMAN(9002086.72,".03////"_BWAGRG,+Y,.BWPOP,1)
+18 QUIT
+19 ;
HELP1 ;EP
+1 ;;Answer "YES" to display screening rates for a specific age range.
+2 ;;If you choose to display for an age range, you will be given the
+3 ;;opportunity to select the age range. For example, you might choose
+4 ;;to display from ages 50-75.
+5 ;;Answer "NO" to display screening rates for all ages.
+6 SET BWTAB=5
SET BWLINL="HELP1"
DO HELPTX
+7 QUIT
+8 ;
PRINTX ;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
WRITE !,T,$PIECE(X,";;",2)
+3 QUIT
+4 ;
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 FAIL,I,Y1,Y2
+6 SET FAIL=0
+7 ;---> CHECK EACH RANGE.
+8 SET Y1=$PIECE(X,"-")
SET Y2=$PIECE(X,"-",2)
+9 ;---> EACH END OF EACH RANGE SHOULD BE A NUMBER.
+10 IF (Y1'?1N.N)!(Y2'?1N.N)
SET X=""
QUIT
+11 ;---> THE LOWER NUMBER SHOULD BE FIRST.
+12 IF Y2<Y1
SET FAIL=1
+13 IF FAIL
SET X=""
QUIT
+14 QUIT
