WVRPSCR2 ;HCIOFO/JWR,FT-WVRPSCR cont'd, Gathers Pap Regimens info. ;6/17/99 11:46
;;1.0;WOMEN'S HEALTH;**7**;Sep 30, 1998
EN ;---> NOW COLLATE DATA FROM ^TMP ARRAY INTO LOCAL WVTMP REPORT ARRAY.
;---> FIRST, SEED LOCAL ARRAY WITH ZEROS.
K WVPR
;
;---> COLLATE DATA.
S J="" F S J=$O(^TMP("WVP",$J,J)) Q:J="" D
.S N=0 F S N=$O(^TMP("WVP",$J,J,N)) Q:'N D
..F M=1,28 S WVJTYP=$S(M=1:"PAPR",1:"MAM") D
...Q:$D(^TMP("WVP",$J,J,N,1,M)) ;DON'T INCLUDE IF PATIENT HAD ANY ABNOR
...S P=0,Q=0
...F S P=$O(^TMP("WVP",$J,J,N,0,M,P)) Q:'P S Q=Q+1
...Q:'Q
...I '$D(WVPR(WVJTYP,J,M,Q)) S WVPR(WVJTYP,J,M,Q)=1 Q
...S WVPR(WVJTYP,J,M,Q)=WVPR(WVJTYP,J,M,Q)+1
;
;---> STORE ALL NODES >5 IN THE 5+ NODE.
F M=1,28 S WVJTYP=$S(M=1:"PAPR",1:"MAM") D
.S J="" F S J=$O(^TMP("WVP",$J,J)) Q:J="" D
..S Q=5
..F S Q=$O(WVPR(WVJTYP,J,M,Q)) Q:'Q D
...S WVPR(WVJTYP,J,M,5)=$G(WVPR(WVJTYP,J,M,5))+WVPR(WVJTYP,J,M,Q)
;
;---> FIGURE PERCENTAGES OF WOMEN AND STORE IN ARRAY.
F M=1,28 S WVJTYP=$S(M=1:"PAPR",1:"MAM") D
.S J="" F S J=$O(WVPR(WVJTYP,J)) Q:J="" D
..F Q=1:1:5 I $D(WVPR(WVJTYP,J,M,Q)) S $P(WVPR(WVJTYP,J,M,Q),U,2)=$J((+WVPR(WVJTYP,J,M,Q)/WVTOT),0,2)
;
PRINT N BLANK,DATA
S $P(BLANK," ",41)="",CN=7.001
S WVJST=0 F M=1,28 S WVJTYP=$S(M=1:"PAPR",1:"MAM") S:M=28 CN=16.001 D
.S J="" F S J=$O(WVPR(WVJTYP,J)) Q:J="" D
..Q:'$D(WVPR(WVJTYP,J,M))
..N P F Q=1:1:5 S DATA=$G(WVPR(WVJTYP,J,M,Q)) D
...S P(1)=$P(DATA,U),P(2)=$P(DATA,U,2)*100 S:P(1)="" P(1)=0
...S P("NO")=$G(P("NO"))_$E(BLANK,1,6-$L(P(1)))_P(1)
...S P("PCT")=$G(P("PCT"))_$E(BLANK,1,5-$L(P(2)))_P(2)_"%"
..S ^TMP("WV",$J,CN,0)=" "_J_$E(BLANK,1,36-$L(J))_"# of Women "_P("NO")
..S CN=CN+.001
..S ^TMP("WV",$J,CN,0)=$E(BLANK,1,37)_"% of Women "_P("PCT")
..S CN=CN+.001
..S ^TMP("WV",$J,CN,0)=""
..S CN=CN+.001
Q
HDR ;
Q:N>7.9&(N'>16)
S WVJHDR=$S(N<8:"PAP REGIMEN",N>16:"AGE GROUPS ",1:" ")
W !!," ",WVJHDR," 1 2 3 4 5+"
W !," ----------- ----- ----- ----- ----- -----"
Q
ACTIVE(WVBEGIN,WVEND,WVAGRG) ; Count active patients in WV PATIENT file (#790).
; Active is defined as not having a DATE INACTIVE (#.24) field
; value or that value falls within the date range selected.
; WVBEGIN - start of date range in FM format
; WVEND - end of date range in FM format
N WVLOOP,WVNODE,WVACTIVE,WVAGE
S (WVLOOP,WVACTIVE)=0
; check if date range exists
I 'WVBEGIN!('WVEND)!(WVAGRG="") S WVACTIVE=1 Q WVACTIVE
F S WVLOOP=$O(^WV(790,WVLOOP)) Q:'WVLOOP D
.S WVNODE=$G(^WV(790,WVLOOP,0))
.Q:WVNODE=""
.S WVAGE=+$$AGE^WVUTL9(WVLOOP)
.I WVAGRG'=1 Q:((WVAGE<$P(WVAGRG,"-"))!(WVAGE>$P(WVAGRG,"-",2)))
.I +$P(WVNODE,U,24)'>0 S WVACTIVE=WVACTIVE+1 Q ;active
.Q:$P(WVNODE,U,24)<WVBEGIN ;inactive before date range
.I $P(WVNODE,U,24)>WVEND S WVACTIVE=WVACTIVE+1 Q ;inactive after range
.S WVACTIVE=WVACTIVE+1 ;active at some time within range
.Q
S:WVACTIVE=0 WVACTIVE=1
Q WVACTIVE
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVRPSCR2 3053 printed Sep 23, 2025@20:24:15 Page 2
WVRPSCR2 ;HCIOFO/JWR,FT-WVRPSCR cont'd, Gathers Pap Regimens info. ;6/17/99 11:46
+1 ;;1.0;WOMEN'S HEALTH;**7**;Sep 30, 1998
EN ;---> NOW COLLATE DATA FROM ^TMP ARRAY INTO LOCAL WVTMP REPORT ARRAY.
+1 ;---> FIRST, SEED LOCAL ARRAY WITH ZEROS.
+2 KILL WVPR
+3 ;
+4 ;---> COLLATE DATA.
+5 SET J=""
FOR
SET J=$ORDER(^TMP("WVP",$JOB,J))
if J=""
QUIT
Begin DoDot:1
+6 SET N=0
FOR
SET N=$ORDER(^TMP("WVP",$JOB,J,N))
if 'N
QUIT
Begin DoDot:2
+7 FOR M=1,28
SET WVJTYP=$SELECT(M=1:"PAPR",1:"MAM")
Begin DoDot:3
+8 ;DON'T INCLUDE IF PATIENT HAD ANY ABNOR
if $DATA(^TMP("WVP",$JOB,J,N,1,M))
QUIT
+9 SET P=0
SET Q=0
+10 FOR
SET P=$ORDER(^TMP("WVP",$JOB,J,N,0,M,P))
if 'P
QUIT
SET Q=Q+1
+11 if 'Q
QUIT
+12 IF '$DATA(WVPR(WVJTYP,J,M,Q))
SET WVPR(WVJTYP,J,M,Q)=1
QUIT
+13 SET WVPR(WVJTYP,J,M,Q)=WVPR(WVJTYP,J,M,Q)+1
End DoDot:3
End DoDot:2
End DoDot:1
+14 ;
+15 ;---> STORE ALL NODES >5 IN THE 5+ NODE.
+16 FOR M=1,28
SET WVJTYP=$SELECT(M=1:"PAPR",1:"MAM")
Begin DoDot:1
+17 SET J=""
FOR
SET J=$ORDER(^TMP("WVP",$JOB,J))
if J=""
QUIT
Begin DoDot:2
+18 SET Q=5
+19 FOR
SET Q=$ORDER(WVPR(WVJTYP,J,M,Q))
if 'Q
QUIT
Begin DoDot:3
+20 SET WVPR(WVJTYP,J,M,5)=$GET(WVPR(WVJTYP,J,M,5))+WVPR(WVJTYP,J,M,Q)
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;
+22 ;---> FIGURE PERCENTAGES OF WOMEN AND STORE IN ARRAY.
+23 FOR M=1,28
SET WVJTYP=$SELECT(M=1:"PAPR",1:"MAM")
Begin DoDot:1
+24 SET J=""
FOR
SET J=$ORDER(WVPR(WVJTYP,J))
if J=""
QUIT
Begin DoDot:2
+25 FOR Q=1:1:5
IF $DATA(WVPR(WVJTYP,J,M,Q))
SET $PIECE(WVPR(WVJTYP,J,M,Q),U,2)=$JUSTIFY((+WVPR(WVJTYP,J,M,Q)/WVTOT),0,2)
End DoDot:2
End DoDot:1
+26 ;
PRINT NEW BLANK,DATA
+1 SET $PIECE(BLANK," ",41)=""
SET CN=7.001
+2 SET WVJST=0
FOR M=1,28
SET WVJTYP=$SELECT(M=1:"PAPR",1:"MAM")
if M=28
SET CN=16.001
Begin DoDot:1
+3 SET J=""
FOR
SET J=$ORDER(WVPR(WVJTYP,J))
if J=""
QUIT
Begin DoDot:2
+4 if '$DATA(WVPR(WVJTYP,J,M))
QUIT
+5 NEW P
FOR Q=1:1:5
SET DATA=$GET(WVPR(WVJTYP,J,M,Q))
Begin DoDot:3
+6 SET P(1)=$PIECE(DATA,U)
SET P(2)=$PIECE(DATA,U,2)*100
if P(1)=""
SET P(1)=0
+7 SET P("NO")=$GET(P("NO"))_$EXTRACT(BLANK,1,6-$LENGTH(P(1)))_P(1)
+8 SET P("PCT")=$GET(P("PCT"))_$EXTRACT(BLANK,1,5-$LENGTH(P(2)))_P(2)_"%"
End DoDot:3
+9 SET ^TMP("WV",$JOB,CN,0)=" "_J_$EXTRACT(BLANK,1,36-$LENGTH(J))_"# of Women "_P("NO")
+10 SET CN=CN+.001
+11 SET ^TMP("WV",$JOB,CN,0)=$EXTRACT(BLANK,1,37)_"% of Women "_P("PCT")
+12 SET CN=CN+.001
+13 SET ^TMP("WV",$JOB,CN,0)=""
+14 SET CN=CN+.001
End DoDot:2
End DoDot:1
+15 QUIT
HDR ;
+1 if N>7.9&(N'>16)
QUIT
+2 SET WVJHDR=$SELECT(N<8:"PAP REGIMEN",N>16:"AGE GROUPS ",1:" ")
+3 WRITE !!," ",WVJHDR," 1 2 3 4 5+"
+4 WRITE !," ----------- ----- ----- ----- ----- -----"
+5 QUIT
ACTIVE(WVBEGIN,WVEND,WVAGRG) ; Count active patients in WV PATIENT file (#790).
+1 ; Active is defined as not having a DATE INACTIVE (#.24) field
+2 ; value or that value falls within the date range selected.
+3 ; WVBEGIN - start of date range in FM format
+4 ; WVEND - end of date range in FM format
+5 NEW WVLOOP,WVNODE,WVACTIVE,WVAGE
+6 SET (WVLOOP,WVACTIVE)=0
+7 ; check if date range exists
+8 IF 'WVBEGIN!('WVEND)!(WVAGRG="")
SET WVACTIVE=1
QUIT WVACTIVE
+9 FOR
SET WVLOOP=$ORDER(^WV(790,WVLOOP))
if 'WVLOOP
QUIT
Begin DoDot:1
+10 SET WVNODE=$GET(^WV(790,WVLOOP,0))
+11 if WVNODE=""
QUIT
+12 SET WVAGE=+$$AGE^WVUTL9(WVLOOP)
+13 IF WVAGRG'=1
if ((WVAGE<$PIECE(WVAGRG,"-"))!(WVAGE>$PIECE(WVAGRG,"-",2)))
QUIT
+14 ;active
IF +$PIECE(WVNODE,U,24)'>0
SET WVACTIVE=WVACTIVE+1
QUIT
+15 ;inactive before date range
if $PIECE(WVNODE,U,24)<WVBEGIN
QUIT
+16 ;inactive after range
IF $PIECE(WVNODE,U,24)>WVEND
SET WVACTIVE=WVACTIVE+1
QUIT
+17 ;active at some time within range
SET WVACTIVE=WVACTIVE+1
+18 QUIT
End DoDot:1
+19 if WVACTIVE=0
SET WVACTIVE=1
+20 QUIT WVACTIVE
+21 ;
