- 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 Jan 18, 2025@03:49:01 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