WVRPPCD3 ;HCIOFO/FT,JR-REPORT: PROCEDURES STATISTICS; ;7/23/01 13:33
;;1.0;WOMEN'S HEALTH;**12**;Sep 30, 1998
;
; This routine uses the following IAs:
; <NONE>
;
FLATFL ;EP
;---> WRITE OUT RESULTS AND PECENTAGES IN A FLAT FILE.
;---> PIECE VALUES: 1=PROC TYPE, 2=NORMAL PATS, 3=NORMAL PATS%
;---> 4=NORMAL PROC 5=NORMAL PROC% 6=ABNORM PATS
;---> 7=ABNORM PATS% 8=ABNORM PROC 9=ABNORM PROC%
;---> 10=NO RES PATS 11=NO RES PATS% 12=NO RES PROC
;---> 13=NO RES PROC% 14=TOTAL PATS 15=TOTAL PROC,
;---> 16=AGE GROUP, 17=NORM VETS PROC.
;---> 18=NORM VETS PATIENTS, 19=ABN VETS PROC.
;---> 20=ABN VETS PATIENTS, 21=NO RES VETS PROC
;---> 22=NO RES VETS PATIENTS 23=TOT # VET PATIENTS
;---> 24=TOT VET PROCEDURES
S FE=""
F S FE=$O(^TMP("WVRES",$J,FE)) Q:FE="" S FI=0 F S FI=$O(^TMP("WVRES",$J,FE,FI)) Q:'FI S N=0 F S N=$O(^TMP("WVRES",$J,FE,FI,N)) Q:'N D
.S M=0,(WVPN,X)=$P($G(^WV(790.2,N,0)),U)
.F S M=$O(^TMP("WVRES",$J,FE,FI,N,M)) Q:'M D
..S X=WVPN,(T,P)=0,J=""
..S PA=$G(^TMP("WVRES",$J,FE,FI,N,M,"VT","PA"))
..S CM=$G(^TMP("WVRES",$J,FE,FI,N,M,"CM","PA",0))
..S CM2=$G(^TMP("WVRES",$J,FE,FI,N,M,"CM","PA",2))
..S (TR2,JR2,TR,JR)="" F I=0,1,2 D
...S X=X_U_^TMP("WVRES",$J,FE,FI,N,M,I,"P")
...S X=X_U_$J((^TMP("WVRES",$J,FE,FI,N,M,I,"P")*100/^TMP("WVRES",$J,FE,FI,N,M,"P")),1,0)
...S X=X_U_^TMP("WVRES",$J,FE,FI,N,M,I,"T")
...S X=X_U_$J((^TMP("WVRES",$J,FE,FI,N,M,I,"T")*100/^TMP("WVRES",$J,FE,FI,N,M,"T")),1,0)
...S J=J_U_$G(^TMP("WVRES",$J,FE,FI,N,M,I,"VT","T")) ;# of procedures total/result
...S J=J_U_$G(^TMP("WVRES",$J,FE,FI,N,M,I,"VT","P")) ;# of pat having this procedure
...S T=T+$G(^TMP("WVRES",$J,FE,FI,N,M,I,"VT","T"))
...S JR=$G(JR)_U_$G(^TMP("WVRES",$J,FE,FI,N,M,I,"CM","T",0)) ;# of procedures total/result
...S JR=JR_U_$G(^TMP("WVRES",$J,FE,FI,N,M,I,"CM","P",0)) ;# of pat having this procedure
...S TR=TR+$G(^TMP("WVRES",$J,FE,FI,N,M,I,"CM","T",0))
...S JR2=$G(JR2)_U_$G(^TMP("WVRES",$J,FE,FI,N,M,I,"CM","T",2)) ;# of procedures total/result
...S JR2=JR2_U_$G(^TMP("WVRES",$J,FE,FI,N,M,I,"CM","P",2)) ;# of pat having this procedure
...S TR2=TR2+$G(^TMP("WVRES",$J,FE,FI,N,M,I,"CM","T",2))
..S X=X_U_^TMP("WVRES",$J,FE,FI,N,M,"P")_U_^TMP("WVRES",$J,FE,FI,N,M,"T")_U_M_J_U_T_U_PA_JR_U_TR_U_CM_JR2_U_TR2_U_CM2
..S ^TMP("WVRES",$J,"R",FE,FI,WVPN,M)=X
.;--->
.;---> NOW GET TOTALS FOR THIS PROCEDURE.
.N A,B,C,D,E,F,G,H,I,J,K,L,M,O,WA,WB,WC,WD,WE,WF,WG,WH,WI,WJ,WK,WL
.S (A,B,C,D,E,F,G,H,I,K,L,M,R,O,WA,WB,WC,WD,WE,WF,WG,WH,WI,WJ,WK,WL)=0
.F S M=$O(^TMP("WVRES",$J,"R",FE,FI,WVPN,M)) Q:'M D
..S J=$O(^WV(790.2,"B",WVPN,""))
..S Y=^TMP("WVRES",$J,"R",FE,FI,WVPN,M)
..S A=A+$P(Y,U,2),B=B+$P(Y,U,4),C=C+$P(Y,U,6)
..S D=D+$P(Y,U,8),E=E+$P(Y,U,10),F=F+$P(Y,U,12)
..S H=H+$P(Y,U,17),I=I+$P(Y,U,18),K=K+$P(Y,U,19)
..S L=L+$P(Y,U,20),R=R+$P(Y,U,21),O=O+$P(Y,U,22)
..S WA=WA+$P(Y,U,25),WB=WB+$P(Y,U,26),WC=WC+$P(Y,U,27)
..S WD=WD+$P(Y,U,28),WE=WE+$P(Y,U,29),WF=WF+$P(Y,U,30)
..S WG=WG+$P(Y,U,33),WH=WH+$P(Y,U,34),WI=WI+$P(Y,U,35)
..S WJ=WJ+$P(Y,U,36),WK=WK+$P(Y,U,37),WL=WL+$P(Y,U,38)
.S X=WVPN_U_A_U_$J(A*100/^TMP("WVRES",$J,FE,FI,N,"P"),1,0)
.S X=X_U_B_U_$J(B*100/^TMP("WVRES",$J,FE,FI,N,"T"),1,0)
.S X=X_U_C_U_$J(C*100/^TMP("WVRES",$J,FE,FI,N,"P"),1,0)
.S X=X_U_D_U_$J(D*100/^TMP("WVRES",$J,FE,FI,N,"T"),1,0)
.S X=X_U_E_U_$J(E*100/^TMP("WVRES",$J,FE,FI,N,"P"),1,0)
.S X=X_U_F_U_$J(F*100/^TMP("WVRES",$J,FE,FI,N,"T"),1,0)
.S X=X_U_^TMP("WVRES",$J,FE,FI,N,"P")_U_^TMP("WVRES",$J,FE,FI,N,"T")_U_"ALL"
.S J=U_H_U_I_U_K_U_L_U_R_U_O_U
.S J=J_$G(^TMP("WVRES",$J,FE,FI,N,"VT","T"))_U_$G(^TMP("WVRES",$J,FE,FI,N,"VT","PA"))
.S J=J_U_WA_U_WB_U_WC_U_WD_U_WE_U_WF
.S J=J_U_$G(^TMP("WVRES",$J,FE,FI,N,"CM","T",0))_U_$G(^TMP("WVRES",$J,FE,FI,N,"CM","PA",0))
.S J=J_U_WG_U_WH_U_WI_U_WJ_U_WK_U_WL
.S J=J_U_$G(^TMP("WVRES",$J,FE,FI,N,"CM","T",2))_U_$G(^TMP("WVRES",$J,FE,FI,N,"CM","PA",2))
.S ^TMP("WVRES",$J,"R",FE,FI,WVPN,"ALL")=X_J
Q
NOFAC ; List records with no health care facility
W:$Y>0 @IOF
W !!,"The following Women's Health procedures are not associated with a facility:",!
N WVAN,WVCMN,WVIEN,WVNODE,WVPN
S WVIEN=0
F S WVIEN=$O(^TMP("WVNOHCF",$J,WVIEN)) Q:'WVIEN!(WVPOP) D
.S WVNODE=$G(^WV(790.1,WVIEN,0))
.S WVAN=$P(WVNODE,U,1) ;accession #
.S:WVAN="" WVAN="IEN is "_WVIEN
.S WVPN=+$P(WVNODE,U,2)
.S WVCMN=$$CMGR^WVUTL1(WVPN)
.I $Y+6>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D NOFACHDR
.W !,"Accession #: "_WVAN,?30,"Case Manager: "_WVCMN
.Q
Q
NOFACHDR ; No Facility Header
W:$Y>0 @IOF
Q
FACLIST ; create array to identify facilities chosen
N WVIEN,WVIEN1,WVNAME
K WVSB1
I '$D(WVSB("ALL")) D
.S WVIEN=0
.F S WVIEN=$O(WVSB(WVIEN)) Q:'WVIEN D
..S WVIEN1=$P($G(^WV(790.02,WVIEN,0)),U,1)
..Q:'WVIEN1!(WVIEN'=WVIEN1)
..S WVNAME=$$INSTTX^WVUTL6(WVIEN)
..Q:WVNAME=""
..S WVSB1(WVNAME,WVIEN)=""
..Q
.Q
I $D(WVSB("ALL")) D
.S WVIEN=0
.F S WVIEN=$O(^WV(790.02,WVIEN)) Q:'WVIEN D
..S WVIEN1=$P($G(^WV(790.02,WVIEN,0)),U,1)
..Q:'WVIEN1!(WVIEN'=WVIEN1)
..S WVNAME=$$INSTTX^WVUTL6(WVIEN)
..Q:WVNAME=""
..S WVSB1(WVNAME,WVIEN)=""
..Q
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVRPPCD3 5320 printed Sep 23, 2025@20:24:12 Page 2
WVRPPCD3 ;HCIOFO/FT,JR-REPORT: PROCEDURES STATISTICS; ;7/23/01 13:33
+1 ;;1.0;WOMEN'S HEALTH;**12**;Sep 30, 1998
+2 ;
+3 ; This routine uses the following IAs:
+4 ; <NONE>
+5 ;
FLATFL ;EP
+1 ;---> WRITE OUT RESULTS AND PECENTAGES IN A FLAT FILE.
+2 ;---> PIECE VALUES: 1=PROC TYPE, 2=NORMAL PATS, 3=NORMAL PATS%
+3 ;---> 4=NORMAL PROC 5=NORMAL PROC% 6=ABNORM PATS
+4 ;---> 7=ABNORM PATS% 8=ABNORM PROC 9=ABNORM PROC%
+5 ;---> 10=NO RES PATS 11=NO RES PATS% 12=NO RES PROC
+6 ;---> 13=NO RES PROC% 14=TOTAL PATS 15=TOTAL PROC,
+7 ;---> 16=AGE GROUP, 17=NORM VETS PROC.
+8 ;---> 18=NORM VETS PATIENTS, 19=ABN VETS PROC.
+9 ;---> 20=ABN VETS PATIENTS, 21=NO RES VETS PROC
+10 ;---> 22=NO RES VETS PATIENTS 23=TOT # VET PATIENTS
+11 ;---> 24=TOT VET PROCEDURES
+12 SET FE=""
+13 FOR
SET FE=$ORDER(^TMP("WVRES",$JOB,FE))
if FE=""
QUIT
SET FI=0
FOR
SET FI=$ORDER(^TMP("WVRES",$JOB,FE,FI))
if 'FI
QUIT
SET N=0
FOR
SET N=$ORDER(^TMP("WVRES",$JOB,FE,FI,N))
if 'N
QUIT
Begin DoDot:1
+14 SET M=0
SET (WVPN,X)=$PIECE($GET(^WV(790.2,N,0)),U)
+15 FOR
SET M=$ORDER(^TMP("WVRES",$JOB,FE,FI,N,M))
if 'M
QUIT
Begin DoDot:2
+16 SET X=WVPN
SET (T,P)=0
SET J=""
+17 SET PA=$GET(^TMP("WVRES",$JOB,FE,FI,N,M,"VT","PA"))
+18 SET CM=$GET(^TMP("WVRES",$JOB,FE,FI,N,M,"CM","PA",0))
+19 SET CM2=$GET(^TMP("WVRES",$JOB,FE,FI,N,M,"CM","PA",2))
+20 SET (TR2,JR2,TR,JR)=""
FOR I=0,1,2
Begin DoDot:3
+21 SET X=X_U_^TMP("WVRES",$JOB,FE,FI,N,M,I,"P")
+22 SET X=X_U_$JUSTIFY((^TMP("WVRES",$JOB,FE,FI,N,M,I,"P")*100/^TMP("WVRES",$JOB,FE,FI,N,M,"P")),1,0)
+23 SET X=X_U_^TMP("WVRES",$JOB,FE,FI,N,M,I,"T")
+24 SET X=X_U_$JUSTIFY((^TMP("WVRES",$JOB,FE,FI,N,M,I,"T")*100/^TMP("WVRES",$JOB,FE,FI,N,M,"T")),1,0)
+25 ;# of procedures total/result
SET J=J_U_$GET(^TMP("WVRES",$JOB,FE,FI,N,M,I,"VT","T"))
+26 ;# of pat having this procedure
SET J=J_U_$GET(^TMP("WVRES",$JOB,FE,FI,N,M,I,"VT","P"))
+27 SET T=T+$GET(^TMP("WVRES",$JOB,FE,FI,N,M,I,"VT","T"))
+28 ;# of procedures total/result
SET JR=$GET(JR)_U_$GET(^TMP("WVRES",$JOB,FE,FI,N,M,I,"CM","T",0))
+29 ;# of pat having this procedure
SET JR=JR_U_$GET(^TMP("WVRES",$JOB,FE,FI,N,M,I,"CM","P",0))
+30 SET TR=TR+$GET(^TMP("WVRES",$JOB,FE,FI,N,M,I,"CM","T",0))
+31 ;# of procedures total/result
SET JR2=$GET(JR2)_U_$GET(^TMP("WVRES",$JOB,FE,FI,N,M,I,"CM","T",2))
+32 ;# of pat having this procedure
SET JR2=JR2_U_$GET(^TMP("WVRES",$JOB,FE,FI,N,M,I,"CM","P",2))
+33 SET TR2=TR2+$GET(^TMP("WVRES",$JOB,FE,FI,N,M,I,"CM","T",2))
End DoDot:3
+34 SET X=X_U_^TMP("WVRES",$JOB,FE,FI,N,M,"P")_U_^TMP("WVRES",$JOB,FE,FI,N,M,"T")_U_M_J_U_T_U_PA_JR_U_TR_U_CM_JR2_U_TR2_U_CM2
+35 SET ^TMP("WVRES",$JOB,"R",FE,FI,WVPN,M)=X
End DoDot:2
+36 ;--->
+37 ;---> NOW GET TOTALS FOR THIS PROCEDURE.
+38 NEW A,B,C,D,E,F,G,H,I,J,K,L,M,O,WA,WB,WC,WD,WE,WF,WG,WH,WI,WJ,WK,WL
+39 SET (A,B,C,D,E,F,G,H,I,K,L,M,R,O,WA,WB,WC,WD,WE,WF,WG,WH,WI,WJ,WK,WL)=0
+40 FOR
SET M=$ORDER(^TMP("WVRES",$JOB,"R",FE,FI,WVPN,M))
if 'M
QUIT
Begin DoDot:2
+41 SET J=$ORDER(^WV(790.2,"B",WVPN,""))
+42 SET Y=^TMP("WVRES",$JOB,"R",FE,FI,WVPN,M)
+43 SET A=A+$PIECE(Y,U,2)
SET B=B+$PIECE(Y,U,4)
SET C=C+$PIECE(Y,U,6)
+44 SET D=D+$PIECE(Y,U,8)
SET E=E+$PIECE(Y,U,10)
SET F=F+$PIECE(Y,U,12)
+45 SET H=H+$PIECE(Y,U,17)
SET I=I+$PIECE(Y,U,18)
SET K=K+$PIECE(Y,U,19)
+46 SET L=L+$PIECE(Y,U,20)
SET R=R+$PIECE(Y,U,21)
SET O=O+$PIECE(Y,U,22)
+47 SET WA=WA+$PIECE(Y,U,25)
SET WB=WB+$PIECE(Y,U,26)
SET WC=WC+$PIECE(Y,U,27)
+48 SET WD=WD+$PIECE(Y,U,28)
SET WE=WE+$PIECE(Y,U,29)
SET WF=WF+$PIECE(Y,U,30)
+49 SET WG=WG+$PIECE(Y,U,33)
SET WH=WH+$PIECE(Y,U,34)
SET WI=WI+$PIECE(Y,U,35)
+50 SET WJ=WJ+$PIECE(Y,U,36)
SET WK=WK+$PIECE(Y,U,37)
SET WL=WL+$PIECE(Y,U,38)
End DoDot:2
+51 SET X=WVPN_U_A_U_$JUSTIFY(A*100/^TMP("WVRES",$JOB,FE,FI,N,"P"),1,0)
+52 SET X=X_U_B_U_$JUSTIFY(B*100/^TMP("WVRES",$JOB,FE,FI,N,"T"),1,0)
+53 SET X=X_U_C_U_$JUSTIFY(C*100/^TMP("WVRES",$JOB,FE,FI,N,"P"),1,0)
+54 SET X=X_U_D_U_$JUSTIFY(D*100/^TMP("WVRES",$JOB,FE,FI,N,"T"),1,0)
+55 SET X=X_U_E_U_$JUSTIFY(E*100/^TMP("WVRES",$JOB,FE,FI,N,"P"),1,0)
+56 SET X=X_U_F_U_$JUSTIFY(F*100/^TMP("WVRES",$JOB,FE,FI,N,"T"),1,0)
+57 SET X=X_U_^TMP("WVRES",$JOB,FE,FI,N,"P")_U_^TMP("WVRES",$JOB,FE,FI,N,"T")_U_"ALL"
+58 SET J=U_H_U_I_U_K_U_L_U_R_U_O_U
+59 SET J=J_$GET(^TMP("WVRES",$JOB,FE,FI,N,"VT","T"))_U_$GET(^TMP("WVRES",$JOB,FE,FI,N,"VT","PA"))
+60 SET J=J_U_WA_U_WB_U_WC_U_WD_U_WE_U_WF
+61 SET J=J_U_$GET(^TMP("WVRES",$JOB,FE,FI,N,"CM","T",0))_U_$GET(^TMP("WVRES",$JOB,FE,FI,N,"CM","PA",0))
+62 SET J=J_U_WG_U_WH_U_WI_U_WJ_U_WK_U_WL
+63 SET J=J_U_$GET(^TMP("WVRES",$JOB,FE,FI,N,"CM","T",2))_U_$GET(^TMP("WVRES",$JOB,FE,FI,N,"CM","PA",2))
+64 SET ^TMP("WVRES",$JOB,"R",FE,FI,WVPN,"ALL")=X_J
End DoDot:1
+65 QUIT
NOFAC ; List records with no health care facility
+1 if $Y>0
WRITE @IOF
+2 WRITE !!,"The following Women's Health procedures are not associated with a facility:",!
+3 NEW WVAN,WVCMN,WVIEN,WVNODE,WVPN
+4 SET WVIEN=0
+5 FOR
SET WVIEN=$ORDER(^TMP("WVNOHCF",$JOB,WVIEN))
if 'WVIEN!(WVPOP)
QUIT
Begin DoDot:1
+6 SET WVNODE=$GET(^WV(790.1,WVIEN,0))
+7 ;accession #
SET WVAN=$PIECE(WVNODE,U,1)
+8 if WVAN=""
SET WVAN="IEN is "_WVIEN
+9 SET WVPN=+$PIECE(WVNODE,U,2)
+10 SET WVCMN=$$CMGR^WVUTL1(WVPN)
+11 IF $Y+6>IOSL
if WVCRT
DO DIRZ^WVUTL3
if WVPOP
QUIT
DO NOFACHDR
+12 WRITE !,"Accession #: "_WVAN,?30,"Case Manager: "_WVCMN
+13 QUIT
End DoDot:1
+14 QUIT
NOFACHDR ; No Facility Header
+1 if $Y>0
WRITE @IOF
+2 QUIT
FACLIST ; create array to identify facilities chosen
+1 NEW WVIEN,WVIEN1,WVNAME
+2 KILL WVSB1
+3 IF '$DATA(WVSB("ALL"))
Begin DoDot:1
+4 SET WVIEN=0
+5 FOR
SET WVIEN=$ORDER(WVSB(WVIEN))
if 'WVIEN
QUIT
Begin DoDot:2
+6 SET WVIEN1=$PIECE($GET(^WV(790.02,WVIEN,0)),U,1)
+7 if 'WVIEN1!(WVIEN'=WVIEN1)
QUIT
+8 SET WVNAME=$$INSTTX^WVUTL6(WVIEN)
+9 if WVNAME=""
QUIT
+10 SET WVSB1(WVNAME,WVIEN)=""
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 IF $DATA(WVSB("ALL"))
Begin DoDot:1
+14 SET WVIEN=0
+15 FOR
SET WVIEN=$ORDER(^WV(790.02,WVIEN))
if 'WVIEN
QUIT
Begin DoDot:2
+16 SET WVIEN1=$PIECE($GET(^WV(790.02,WVIEN,0)),U,1)
+17 if 'WVIEN1!(WVIEN'=WVIEN1)
QUIT
+18 SET WVNAME=$$INSTTX^WVUTL6(WVIEN)
+19 if WVNAME=""
QUIT
+20 SET WVSB1(WVNAME,WVIEN)=""
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 QUIT
