WVRPSCR1 ;HCIOFO/FT,JR-Display Compliance Rates (cont.) ;6/17/99 11:47
;;1.0;WOMEN'S HEALTH;**3,7**;Sep 30, 1998
;; Original routine created by IHS/ANMC/MWR
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; THIS REPORT WILL DISPLAY COMPLIANCE RATES FOR PAPS & MAMS.
;; ENTRY POINTS CALLED BY WVRPSCR.
DATA ;EP
;---> SORT AND STORE ARRAY IN ^TMP("WV",$J
K WVTMP,^TMP("WV",$J),^TMP("WVP",$J),WVPR
;---> WVBEGDT1=ONE SECOND BEFORE BEGIN DATE.
;---> WVENDDT1=THE LAST SECOND OF END DATE.
F WVCNT=20,30,40,50,60,70,200 S WVAGRG(WVCNT)=""
S WVBEGDT1=WVBEGDT-.0001,WVENDDT1=WVENDDT+.9999
;
S WVDATE=WVBEGDT1,WVTOT=$$ACTIVE^WVRPSCR2(WVBEGDT,WVENDDT1,WVAGRG)
F S WVDATE=$O(^WV(790.1,"D",WVDATE)) Q:'WVDATE!(WVDATE>WVENDDT1) D
.S WVIEN=0
.F S WVIEN=$O(^WV(790.1,"D",WVDATE,WVIEN)) Q:'WVIEN D
..S Y=^WV(790.1,WVIEN,0)
..S WVDFN=$P(Y,U,2),WVPCDN=$P(Y,U,4),WVRES=$P(Y,U,5)
..;
..;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
..Q:WVRES=8
..;
..;---> QUIT IF NEITHER A PAP (IEN=1) NOR A SCREENING MAM (IEN=28).
..Q:((WVPCDN'=1)&(WVPCDN'=28))
..;
..;---> QUIT IS PATIENT IS NOT WITHIN AGE RANGE.
..S WVAGE=+$$AGE^WVUTL9(WVDFN)
..I WVAGRG'=1 Q:((WVAGE<$P(WVAGRG,"-"))!(WVAGE>$P(WVAGRG,"-",2)))
..;
..;---> GET VALUE OF RESULT: 0=NORMAL, 1=ABNORMAL, 2=NO RESULT
..S WVNORM=$$NORMAL^WVUTL4(WVRES) S:WVNORM=2 WVNORM=0
..;
..S ^TMP("WV",$J,WVDFN,WVNORM,WVPCDN,WVIEN)=""
..I WVPCDN=1 D
...S WVJPAPR=$P($G(^WV(790,WVDFN,0)),U,16)
...I WVJPAPR'>0 S WVJPAPR="NOT SPECIFIED"
...E S WVJPAPR=$P($G(^WV(790.03,WVJPAPR,0)),U)
...S ^TMP("WVP",$J,WVJPAPR,WVDFN,WVNORM,WVPCDN,WVIEN)=""
..I WVPCDN=28 D
...S WVJ=$O(WVAGRG(WVAGE))
...S WVJAGER=$S(WVJ=20:"<20",WVJ=30:"20-29",WVJ=40:"30-39",WVJ=50:"40-49",WVJ=60:"50-59",WVJ=70:"60-69",WVJ=200:">70",1:"AGE UNKNOWN")
...S ^TMP("WVP",$J,WVJAGER,WVDFN,WVNORM,WVPCDN,WVIEN)=""
;
;---> NOW COLLATE DATA FROM ^TMP ARRAY INTO LOCAL WVTMP REPORT ARRAY.
;---> FIRST, SEED LOCAL ARRAY WITH ZEROS.
F M=1,28 D
.N I F I=1:1:5 S WVTMP("RES",M,I)=0
;
;---> COLLATE DATA.
S N=0
F S N=$O(^TMP("WV",$J,N)) Q:'N D
.F M=1,28 D
..Q:$D(^TMP("WV",$J,N,1,M))
..S P=0,Q=0
..F S P=$O(^TMP("WV",$J,N,0,M,P)) Q:'P S Q=Q+1
..Q:'Q
..I '$D(WVTMP("RES",M,Q)) S WVTMP("RES",M,Q)=1 Q
..S WVTMP("RES",M,Q)=WVTMP("RES",M,Q)+1
;
;---> STORE ALL NODES >5 IN THE 5+ NODE.
F M=1,28 D
.S Q=5
.F S Q=$O(WVTMP("RES",M,Q)) Q:'Q D
..S WVTMP("RES",M,5)=WVTMP("RES",M,5)+WVTMP("RES",M,Q)
..K WVTMP("RES",M,Q)
;
;---> FIGURE PERCENTAGES OF WOMEN AND STORE IN ARRAY.
F M=1,28 D
.F Q=1:1:5 S $P(WVTMP("RES",M,Q),U,2)=$J((+WVTMP("RES",M,Q)/WVTOT),0,2)
;
;---> BUILD DISPLAY ARRAY.
N WVNODE K ^TMP("WV",$J)
;
;---> PAPS SUBHEADER LINE.
S WVNODE=$$S(40)_"SCREENING PAPS"
D WRITE(1,WVNODE)
S WVNODE=$$S(39)_"----------------"
D WRITE(2,WVNODE)
S WVNODE=" # of PAPs: 1 2 3 4 5+"
D WRITE(4,WVNODE)
S WVNODE=" ----------- ----- ----- ----- ----- -----"
D WRITE(5,WVNODE)
;
;---> PAPS NUMBER OF WOMEN DATA LINE.
S WVNODE=" # of Women: "
F Q=1:1:5 S WVNODE=WVNODE_$J($P(WVTMP("RES",1,Q),U),6)
D WRITE(6,WVNODE)
S WVNODE=" % of Women: "
F Q=1:1:5 S WVNODE=WVNODE_$J(($P(WVTMP("RES",1,Q),U,2)*100),5)_"%"
D WRITE(7,WVNODE)
;
;---> LINE FEEDS BETWEEN PAPS AND MAMS.
S WVNODE="" D WRITE(8,WVNODE) S WVNODE="" D WRITE(9,WVNODE)
;
;---> MAMS SUBHEADER LINE.
S WVNODE=$$S(40)_"SCREENING MAMS"
D WRITE(10,WVNODE)
S WVNODE=$$S(39)_"----------------"
D WRITE(11,WVNODE)
S WVNODE=" # of MAMs: 1 2 3 4 5+"
D WRITE(13,WVNODE)
S WVNODE=" ----------- ----- ----- ----- ----- -----"
D WRITE(14,WVNODE)
;
;---> PAPS NUMBER OF WOMEN DATA LINE.
S WVNODE=" # of Women: "
F Q=1:1:5 S WVNODE=WVNODE_$J($P(WVTMP("RES",28,Q),U),6)
D WRITE(15,WVNODE)
S WVNODE=" % of Women: "
F Q=1:1:5 S WVNODE=WVNODE_$J(($P(WVTMP("RES",28,Q),U,2)*100),5)_"%"
D WRITE(16,WVNODE)
Q
;
WRITE(I,Y) ;EP
S ^TMP("WV",$J,I,0)=Y
Q
;
S(S) ;EP
;---> SPACES.
Q $$S^WVUTL7($G(S))
;
;
AGERNG(WVAGRG,WVPOP) ;EP
;---> ASK AGE RANGE.
;---> RETURN AGE RANGE IN WVAGRG.
N DIR,DIRUT,Y S WVPOP=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) WVPOP=1
;---> IF NOT DISPLAYING BY AGE RANGE, SET WVAGRG (AGE RANGE)=1, QUIT.
I 'Y S WVAGRG=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(^WV(790.72,DUZ,0)) DIR("B")=$P(^(0),U,3)
D ^DIR K DIR
I $D(DIRUT) S WVPOP=1 Q
D CHECK(.Y)
I Y="" D G BYAGE1
.W !!?5,"* INVALID AGE RANGE. Please begin again."
;---> WVAGRG=SELECTED AGE RANGE(S).
S WVAGRG=Y
D DIC^WVFMAN(790.72,"L",.Y,"","","","`"_DUZ)
Q:Y<0
D DIE^WVFMAN(790.72,".03////"_WVAGRG,+Y,.WVPOP,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 WVTAB=5,WVLINL="HELP1" D HELPTX
Q
;
PRINTX ;EP
N I,T,X S T=$$REPEAT^XLFSTR(" ",WVTAB)
F I=1:1 S X=$T(@WVLINL+I) Q:X'[";;" W !,T,$P(X,";;",2)
Q
;
HELPTX ;EP
;---> CREATES DIR ARRAY FOR DIR. REQUIRED VARIABLES: WVTAB,WVLINL.
N I,T,X S T=$$REPEAT^XLFSTR(" ",WVTAB)
F I=1:1 S X=$T(@WVLINL+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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVRPSCR1 6576 printed Sep 23, 2025@20:24:14 Page 2
WVRPSCR1 ;HCIOFO/FT,JR-Display Compliance Rates (cont.) ;6/17/99 11:47
+1 ;;1.0;WOMEN'S HEALTH;**3,7**;Sep 30, 1998
+2 ;; Original routine created by IHS/ANMC/MWR
+3 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+4 ;; THIS REPORT WILL DISPLAY COMPLIANCE RATES FOR PAPS & MAMS.
+5 ;; ENTRY POINTS CALLED BY WVRPSCR.
DATA ;EP
+1 ;---> SORT AND STORE ARRAY IN ^TMP("WV",$J
+2 KILL WVTMP,^TMP("WV",$JOB),^TMP("WVP",$JOB),WVPR
+3 ;---> WVBEGDT1=ONE SECOND BEFORE BEGIN DATE.
+4 ;---> WVENDDT1=THE LAST SECOND OF END DATE.
+5 FOR WVCNT=20,30,40,50,60,70,200
SET WVAGRG(WVCNT)=""
+6 SET WVBEGDT1=WVBEGDT-.0001
SET WVENDDT1=WVENDDT+.9999
+7 ;
+8 SET WVDATE=WVBEGDT1
SET WVTOT=$$ACTIVE^WVRPSCR2(WVBEGDT,WVENDDT1,WVAGRG)
+9 FOR
SET WVDATE=$ORDER(^WV(790.1,"D",WVDATE))
if 'WVDATE!(WVDATE>WVENDDT1)
QUIT
Begin DoDot:1
+10 SET WVIEN=0
+11 FOR
SET WVIEN=$ORDER(^WV(790.1,"D",WVDATE,WVIEN))
if 'WVIEN
QUIT
Begin DoDot:2
+12 SET Y=^WV(790.1,WVIEN,0)
+13 SET WVDFN=$PIECE(Y,U,2)
SET WVPCDN=$PIECE(Y,U,4)
SET WVRES=$PIECE(Y,U,5)
+14 ;
+15 ;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
+16 if WVRES=8
QUIT
+17 ;
+18 ;---> QUIT IF NEITHER A PAP (IEN=1) NOR A SCREENING MAM (IEN=28).
+19 if ((WVPCDN'=1)&(WVPCDN'=28))
QUIT
+20 ;
+21 ;---> QUIT IS PATIENT IS NOT WITHIN AGE RANGE.
+22 SET WVAGE=+$$AGE^WVUTL9(WVDFN)
+23 IF WVAGRG'=1
if ((WVAGE<$PIECE(WVAGRG,"-"))!(WVAGE>$PIECE(WVAGRG,"-",2)))
QUIT
+24 ;
+25 ;---> GET VALUE OF RESULT: 0=NORMAL, 1=ABNORMAL, 2=NO RESULT
+26 SET WVNORM=$$NORMAL^WVUTL4(WVRES)
if WVNORM=2
SET WVNORM=0
+27 ;
+28 SET ^TMP("WV",$JOB,WVDFN,WVNORM,WVPCDN,WVIEN)=""
+29 IF WVPCDN=1
Begin DoDot:3
+30 SET WVJPAPR=$PIECE($GET(^WV(790,WVDFN,0)),U,16)
+31 IF WVJPAPR'>0
SET WVJPAPR="NOT SPECIFIED"
+32 IF '$TEST
SET WVJPAPR=$PIECE($GET(^WV(790.03,WVJPAPR,0)),U)
+33 SET ^TMP("WVP",$JOB,WVJPAPR,WVDFN,WVNORM,WVPCDN,WVIEN)=""
End DoDot:3
+34 IF WVPCDN=28
Begin DoDot:3
+35 SET WVJ=$ORDER(WVAGRG(WVAGE))
+36 SET WVJAGER=$SELECT(WVJ=20:"<20",WVJ=30:"20-29",WVJ=40:"30-39",WVJ=50:"40-49",WVJ=60:"50-59",WVJ=70:"60-69",WVJ=200:">70",1:"AGE UNKNOWN")
+37 SET ^TMP("WVP",$JOB,WVJAGER,WVDFN,WVNORM,WVPCDN,WVIEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+38 ;
+39 ;---> NOW COLLATE DATA FROM ^TMP ARRAY INTO LOCAL WVTMP REPORT ARRAY.
+40 ;---> FIRST, SEED LOCAL ARRAY WITH ZEROS.
+41 FOR M=1,28
Begin DoDot:1
+42 NEW I
FOR I=1:1:5
SET WVTMP("RES",M,I)=0
End DoDot:1
+43 ;
+44 ;---> COLLATE DATA.
+45 SET N=0
+46 FOR
SET N=$ORDER(^TMP("WV",$JOB,N))
if 'N
QUIT
Begin DoDot:1
+47 FOR M=1,28
Begin DoDot:2
+48 if $DATA(^TMP("WV",$JOB,N,1,M))
QUIT
+49 SET P=0
SET Q=0
+50 FOR
SET P=$ORDER(^TMP("WV",$JOB,N,0,M,P))
if 'P
QUIT
SET Q=Q+1
+51 if 'Q
QUIT
+52 IF '$DATA(WVTMP("RES",M,Q))
SET WVTMP("RES",M,Q)=1
QUIT
+53 SET WVTMP("RES",M,Q)=WVTMP("RES",M,Q)+1
End DoDot:2
End DoDot:1
+54 ;
+55 ;---> STORE ALL NODES >5 IN THE 5+ NODE.
+56 FOR M=1,28
Begin DoDot:1
+57 SET Q=5
+58 FOR
SET Q=$ORDER(WVTMP("RES",M,Q))
if 'Q
QUIT
Begin DoDot:2
+59 SET WVTMP("RES",M,5)=WVTMP("RES",M,5)+WVTMP("RES",M,Q)
+60 KILL WVTMP("RES",M,Q)
End DoDot:2
End DoDot:1
+61 ;
+62 ;---> FIGURE PERCENTAGES OF WOMEN AND STORE IN ARRAY.
+63 FOR M=1,28
Begin DoDot:1
+64 FOR Q=1:1:5
SET $PIECE(WVTMP("RES",M,Q),U,2)=$JUSTIFY((+WVTMP("RES",M,Q)/WVTOT),0,2)
End DoDot:1
+65 ;
+66 ;---> BUILD DISPLAY ARRAY.
+67 NEW WVNODE
KILL ^TMP("WV",$JOB)
+68 ;
+69 ;---> PAPS SUBHEADER LINE.
+70 SET WVNODE=$$S(40)_"SCREENING PAPS"
+71 DO WRITE(1,WVNODE)
+72 SET WVNODE=$$S(39)_"----------------"
+73 DO WRITE(2,WVNODE)
+74 SET WVNODE=" # of PAPs: 1 2 3 4 5+"
+75 DO WRITE(4,WVNODE)
+76 SET WVNODE=" ----------- ----- ----- ----- ----- -----"
+77 DO WRITE(5,WVNODE)
+78 ;
+79 ;---> PAPS NUMBER OF WOMEN DATA LINE.
+80 SET WVNODE=" # of Women: "
+81 FOR Q=1:1:5
SET WVNODE=WVNODE_$JUSTIFY($PIECE(WVTMP("RES",1,Q),U),6)
+82 DO WRITE(6,WVNODE)
+83 SET WVNODE=" % of Women: "
+84 FOR Q=1:1:5
SET WVNODE=WVNODE_$JUSTIFY(($PIECE(WVTMP("RES",1,Q),U,2)*100),5)_"%"
+85 DO WRITE(7,WVNODE)
+86 ;
+87 ;---> LINE FEEDS BETWEEN PAPS AND MAMS.
+88 SET WVNODE=""
DO WRITE(8,WVNODE)
SET WVNODE=""
DO WRITE(9,WVNODE)
+89 ;
+90 ;---> MAMS SUBHEADER LINE.
+91 SET WVNODE=$$S(40)_"SCREENING MAMS"
+92 DO WRITE(10,WVNODE)
+93 SET WVNODE=$$S(39)_"----------------"
+94 DO WRITE(11,WVNODE)
+95 SET WVNODE=" # of MAMs: 1 2 3 4 5+"
+96 DO WRITE(13,WVNODE)
+97 SET WVNODE=" ----------- ----- ----- ----- ----- -----"
+98 DO WRITE(14,WVNODE)
+99 ;
+100 ;---> PAPS NUMBER OF WOMEN DATA LINE.
+101 SET WVNODE=" # of Women: "
+102 FOR Q=1:1:5
SET WVNODE=WVNODE_$JUSTIFY($PIECE(WVTMP("RES",28,Q),U),6)
+103 DO WRITE(15,WVNODE)
+104 SET WVNODE=" % of Women: "
+105 FOR Q=1:1:5
SET WVNODE=WVNODE_$JUSTIFY(($PIECE(WVTMP("RES",28,Q),U,2)*100),5)_"%"
+106 DO WRITE(16,WVNODE)
+107 QUIT
+108 ;
WRITE(I,Y) ;EP
+1 SET ^TMP("WV",$JOB,I,0)=Y
+2 QUIT
+3 ;
S(S) ;EP
+1 ;---> SPACES.
+2 QUIT $$S^WVUTL7($GET(S))
+3 ;
+4 ;
AGERNG(WVAGRG,WVPOP) ;EP
+1 ;---> ASK AGE RANGE.
+2 ;---> RETURN AGE RANGE IN WVAGRG.
+3 NEW DIR,DIRUT,Y
SET WVPOP=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 WVPOP=1
+9 ;---> IF NOT DISPLAYING BY AGE RANGE, SET WVAGRG (AGE RANGE)=1, QUIT.
+10 IF 'Y
SET WVAGRG=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(^WV(790.72,DUZ,0))
SET DIR("B")=$PIECE(^(0),U,3)
+8 DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
SET WVPOP=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 ;---> WVAGRG=SELECTED AGE RANGE(S).
+14 SET WVAGRG=Y
+15 DO DIC^WVFMAN(790.72,"L",.Y,"","","","`"_DUZ)
+16 if Y<0
QUIT
+17 DO DIE^WVFMAN(790.72,".03////"_WVAGRG,+Y,.WVPOP,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 WVTAB=5
SET WVLINL="HELP1"
DO HELPTX
+7 QUIT
+8 ;
PRINTX ;EP
+1 NEW I,T,X
SET T=$$REPEAT^XLFSTR(" ",WVTAB)
+2 FOR I=1:1
SET X=$TEXT(@WVLINL+I)
if X'[";;"
QUIT
WRITE !,T,$PIECE(X,";;",2)
+3 QUIT
+4 ;
HELPTX ;EP
+1 ;---> CREATES DIR ARRAY FOR DIR. REQUIRED VARIABLES: WVTAB,WVLINL.
+2 NEW I,T,X
SET T=$$REPEAT^XLFSTR(" ",WVTAB)
+3 FOR I=1:1
SET X=$TEXT(@WVLINL+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
