BWRPPCD2 ;IHS/ANMC/MWR - REPORT: PROCEDURES STATISTICS;03-Sep-2003 20:12;PLS
;;2.0;WOMEN'S HEALTH;**6,8,9**;MAY 16, 1996
;IHS/CMI/LAB - patch 6 added current community screen
;IHS/CIA/PLS - patch 8 skips procedure lacking a procedure type
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; COLLATING CODE CALLED BY BWRPPCD.
;
;
SORT ;EP
;---> SORT AND STORE LOCAL ARRAY IN ^TMP("BW",$J,1,
K ^TMP("BW",$J),BWRES
;---> BWBEGDT1=ONE SECOND BEFORE BEGIN DATE.
;---> BWENDDT1=THE LAST SECOND OF END DATE.
S BWBEGDT1=BWBEGDT-.0001,BWENDDT1=BWENDDT+.9999
S BWDATE=BWBEGDT1
N BWDFN,BWIEN,BWPCD,Y
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)
..;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
..Q:$P(Y,U,5)=8
..S BWDFN=$P(Y,U,2),BWPCD=$P(Y,U,4)
..; Must have a valid procedure. WiseWoman entries lack a procedure.
..Q:'BWPCD
..S BWAGE=$$BWAGE(BWDFN,$P(Y,U,12),BWAGRG)
..;---> QUIT IF PATIENT'S AGE IS UNKNOWN OR OUTSIDE OF AGE RANGE.
..Q:'BWAGE
..;IHS/CMI/LAB - added current comm screen patch 6
..;---> QUIT IF NOT SELECTING ALL CURRENT COMMUNITIES AND IF THIS
..;---> IS NOT ONE OF THE SELECTED.
..I '$D(BWCC("ALL")) S X=$P($G(^AUPNPAT(BWDFN,11)),U,18) Q:'X Q:'$D(BWCC(X))
..;
..;---> QUIT IF NOT SELECTING FOR ALL PROCEDURES AND IF THIS IS
..;---> NOT ONE OF THE SELECTED PROCEDURES.
..I '$D(BWARR("ALL")) Q:'$D(BWARR(BWPCD))
..;---> FOR BWRES: 0=NORMAL, 1=ABNORMAL, 2=NO RESULT.
..I BWPCD'=44 D
...S BWRES=$$NORMAL^BWUTL4($P(Y,U,5))
..E D
...; Evaluate result for Mammography Project
...S BWRES=$$MPNORM(BWIEN)
..I '$D(^TMP("BW",$J,BWPCD,BWAGE,BWDFN,BWRES)) D Q
...S ^TMP("BW",$J,BWPCD,BWAGE,BWDFN,BWRES)=1
..S X=^TMP("BW",$J,BWPCD,BWAGE,BWDFN,BWRES)+1
..S ^TMP("BW",$J,BWPCD,BWAGE,BWDFN,BWRES)=X
;
;
TOTALS ;EP
;---> N=BWPCD, Q=BWAGE, M=BWDFN, P=BWRES (0,1,2)
N I,M,N,P,Q
S N=0
F S N=$O(^TMP("BW",$J,N)) Q:N="" D
.S Q=0
.F S Q=$O(^TMP("BW",$J,N,Q)) Q:Q="" D
..F I=0,1,2 S BWRES(N,Q,I,"P")=0 S BWRES(N,Q,I,"T")=0
..S M=0,BWRES(N,Q,"P")=0,BWRES(N,Q,"T")=0
..F S M=$O(^TMP("BW",$J,N,Q,M)) Q:M="" D
...S P=-1,BWRES(N,Q,"P")=BWRES(N,Q,"P")+1
...F S P=$O(^TMP("BW",$J,N,Q,M,P)) Q:P="" D
....S BWRES(N,Q,P,"P")=BWRES(N,Q,P,"P")+1
....S BWRES(N,Q,P,"T")=BWRES(N,Q,P,"T")+^TMP("BW",$J,N,Q,M,P)
;
;---> NOW COMPUTE TOTAL #PROCEDURES FOR EACH PROCEDURE, EACH AGE GROUP.
S N=0
F S N=$O(BWRES(N)) Q:'N D
.S Q=0
.F S Q=$O(BWRES(N,Q)) Q:'Q D
..S M=-1
..F S M=$O(BWRES(N,Q,M)) Q:M=""!(M'?1N.N) D
...S BWRES(N,Q,"T")=BWRES(N,Q,"T")+BWRES(N,Q,M,"T")
;
;
;---> NOW COMPUTE TOTAL #PROCEDURES FOR EACH PROCEDURE.
;---> BWRES(N,"P")=TOTAL PATIENTS WHO RECEIVED THIS PROCEDURE.
;---> BWRES(N,"T")=TOTAL TIMES THIS PROCEDURE WAS PERFORMED.
S N=0
F S N=$O(BWRES(N)) Q:'N D
.S Q=0,BWRES(N,"P")=0,BWRES(N,"T")=0
.F S Q=$O(BWRES(N,Q)) Q:'Q D
..S BWRES(N,"P")=BWRES(N,"P")+BWRES(N,Q,"P")
..S BWRES(N,"T")=BWRES(N,"T")+BWRES(N,Q,"T")
;
;
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
S N=0
F S N=$O(BWRES(N)) Q:'N D
.S M=0,(BWPN,X)=$P(^BWPN(N,0),U)
.F S M=$O(BWRES(N,M)) Q:'M D
..S X=BWPN
..F I=0,1,2 D
...S X=X_U_BWRES(N,M,I,"P")
...S X=X_U_$J((BWRES(N,M,I,"P")*100/BWRES(N,M,"P")),1,0)
...S X=X_U_BWRES(N,M,I,"T")
...S X=X_U_$J((BWRES(N,M,I,"T")*100/BWRES(N,M,"T")),1,0)
..S X=X_U_BWRES(N,M,"P")_U_BWRES(N,M,"T")_U_M
..S BWRES("R",BWPN,M)=X
.;--->
.;---> NOW GET TOTALS FOR THIS PROCEDURE.
.N A,B,C,D,E,F
.S (A,B,C,D,E,F,M)=0
.F S M=$O(BWRES("R",BWPN,M)) Q:'M D
..S Y=BWRES("R",BWPN,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 X=BWPN_U_A_U_$J(A*100/BWRES(N,"P"),1,0)
.S X=X_U_B_U_$J(B*100/BWRES(N,"T"),1,0)
.S X=X_U_C_U_$J(C*100/BWRES(N,"P"),1,0)
.S X=X_U_D_U_$J(D*100/BWRES(N,"T"),1,0)
.S X=X_U_E_U_$J(E*100/BWRES(N,"P"),1,0)
.S X=X_U_F_U_$J(F*100/BWRES(N,"T"),1,0)
.S X=X_U_BWRES(N,"P")_U_BWRES(N,"T")_U_"ALL"
.S BWRES("R",BWPN,"ALL")=X
Q
;
;
BWAGE(DFN,DATE,X) ;EP
;---> SET AGE CATEGORY.
;---> REQUIRED VARIABLES: DATE=DATE PATIENT RECEIVED THIS PROCEDURE.
;---> DFN, X=BWAGRG (AGE RANGE).
;---> IF NOT DISPLAY BY AGE, SET ALL BWAGE=1
Q:X=1 1
N AGE,Y,Z
S AGE=$P($$AGEAT^BWUTL1(DFN,DATE),"y/o")
;---> RETURN 0 IF PATIENT'S AGE IS UNKNOWN.
Q:'+AGE 0
;
F I=1:1:$L(X,",") S Y=$P($P(X,",",I),"-",2) Q:AGE'>Y
S Z=$P($P(X,",",I),"-")
;---> RETURN 0 IF PATIENT IS OUTSIDE DATE RANGE.
Q:(AGE<Z!(AGE>Y)) 0
Q Y
; Return a result based on Mammography Assessment Fields
; Input: BWPCD = IEN to BW Procedure File
; Uses: Fields 12.02,12.03,12.04,12.05,12.06
; Result yields one of the following values:
; Normal - 0
; Abnormal - 1
; NO Result - 2
MPNORM(BWPCD) ;
N RES,NORES,NORM,ABNORM,LP
S RES="",NORES=2,NORM=0,ABNORM=1
; Check Negative Finding
Q:$$GET1^DIQ(9002086.1,BWPCD,12.02,"I")!($$GET1^DIQ(9002086.1,BWPCD,12.03,"I")) NORM
F LP=12.04,12.05,12.06 D
.S RES=RES+$$GET1^DIQ(9002086.1,BWPCD,LP,"I")
Q $S('RES:NORES,1:ABNORM)
BWRPPCD2 ;IHS/ANMC/MWR - REPORT: PROCEDURES STATISTICS;03-Sep-2003 20:12;PLS
+1 ;;2.0;WOMEN'S HEALTH;**6,8,9**;MAY 16, 1996
+2 ;IHS/CMI/LAB - patch 6 added current community screen
+3 ;IHS/CIA/PLS - patch 8 skips procedure lacking a procedure type
+4 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+5 ;; COLLATING CODE CALLED BY BWRPPCD.
+6 ;
+7 ;
SORT ;EP
+1 ;---> SORT AND STORE LOCAL ARRAY IN ^TMP("BW",$J,1,
+2 KILL ^TMP("BW",$JOB),BWRES
+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 SET BWDATE=BWBEGDT1
+7 NEW BWDFN,BWIEN,BWPCD,Y
+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 ;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
+13 IF $PIECE(Y,U,5)=8
QUIT
+14 SET BWDFN=$PIECE(Y,U,2)
SET BWPCD=$PIECE(Y,U,4)
+15 ; Must have a valid procedure. WiseWoman entries lack a procedure.
+16 IF 'BWPCD
QUIT
+17 SET BWAGE=$$BWAGE(BWDFN,$PIECE(Y,U,12),BWAGRG)
+18 ;---> QUIT IF PATIENT'S AGE IS UNKNOWN OR OUTSIDE OF AGE RANGE.
+19 IF 'BWAGE
QUIT
+20 ;IHS/CMI/LAB - added current comm screen patch 6
+21 ;---> QUIT IF NOT SELECTING ALL CURRENT COMMUNITIES AND IF THIS
+22 ;---> IS NOT ONE OF THE SELECTED.
+23 IF '$DATA(BWCC("ALL"))
SET X=$PIECE($GET(^AUPNPAT(BWDFN,11)),U,18)
IF 'X
QUIT
IF '$DATA(BWCC(X))
QUIT
+24 ;
+25 ;---> QUIT IF NOT SELECTING FOR ALL PROCEDURES AND IF THIS IS
+26 ;---> NOT ONE OF THE SELECTED PROCEDURES.
+27 IF '$DATA(BWARR("ALL"))
IF '$DATA(BWARR(BWPCD))
QUIT
+28 ;---> FOR BWRES: 0=NORMAL, 1=ABNORMAL, 2=NO RESULT.
+29 IF BWPCD'=44
Begin DoDot:3
+30 SET BWRES=$$NORMAL^BWUTL4($PIECE(Y,U,5))
End DoDot:3
+31 IF '$TEST
Begin DoDot:3
+32 ; Evaluate result for Mammography Project
+33 SET BWRES=$$MPNORM(BWIEN)
End DoDot:3
+34 IF '$DATA(^TMP("BW",$JOB,BWPCD,BWAGE,BWDFN,BWRES))
Begin DoDot:3
+35 SET ^TMP("BW",$JOB,BWPCD,BWAGE,BWDFN,BWRES)=1
End DoDot:3
QUIT
+36 SET X=^TMP("BW",$JOB,BWPCD,BWAGE,BWDFN,BWRES)+1
+37 SET ^TMP("BW",$JOB,BWPCD,BWAGE,BWDFN,BWRES)=X
End DoDot:2
End DoDot:1
+38 ;
+39 ;
TOTALS ;EP
+1 ;---> N=BWPCD, Q=BWAGE, M=BWDFN, P=BWRES (0,1,2)
+2 NEW I,M,N,P,Q
+3 SET N=0
+4 FOR
SET N=$ORDER(^TMP("BW",$JOB,N))
IF N=""
QUIT
Begin DoDot:1
+5 SET Q=0
+6 FOR
SET Q=$ORDER(^TMP("BW",$JOB,N,Q))
IF Q=""
QUIT
Begin DoDot:2
+7 FOR I=0,1,2
SET BWRES(N,Q,I,"P")=0
SET BWRES(N,Q,I,"T")=0
+8 SET M=0
SET BWRES(N,Q,"P")=0
SET BWRES(N,Q,"T")=0
+9 FOR
SET M=$ORDER(^TMP("BW",$JOB,N,Q,M))
IF M=""
QUIT
Begin DoDot:3
+10 SET P=-1
SET BWRES(N,Q,"P")=BWRES(N,Q,"P")+1
+11 FOR
SET P=$ORDER(^TMP("BW",$JOB,N,Q,M,P))
IF P=""
QUIT
Begin DoDot:4
+12 SET BWRES(N,Q,P,"P")=BWRES(N,Q,P,"P")+1
+13 SET BWRES(N,Q,P,"T")=BWRES(N,Q,P,"T")+^TMP("BW",$JOB,N,Q,M,P)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 ;
+15 ;---> NOW COMPUTE TOTAL #PROCEDURES FOR EACH PROCEDURE, EACH AGE GROUP.
+16 SET N=0
+17 FOR
SET N=$ORDER(BWRES(N))
IF 'N
QUIT
Begin DoDot:1
+18 SET Q=0
+19 FOR
SET Q=$ORDER(BWRES(N,Q))
IF 'Q
QUIT
Begin DoDot:2
+20 SET M=-1
+21 FOR
SET M=$ORDER(BWRES(N,Q,M))
IF M=""!(M'?1N.N)
QUIT
Begin DoDot:3
+22 SET BWRES(N,Q,"T")=BWRES(N,Q,"T")+BWRES(N,Q,M,"T")
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;
+24 ;
+25 ;---> NOW COMPUTE TOTAL #PROCEDURES FOR EACH PROCEDURE.
+26 ;---> BWRES(N,"P")=TOTAL PATIENTS WHO RECEIVED THIS PROCEDURE.
+27 ;---> BWRES(N,"T")=TOTAL TIMES THIS PROCEDURE WAS PERFORMED.
+28 SET N=0
+29 FOR
SET N=$ORDER(BWRES(N))
IF 'N
QUIT
Begin DoDot:1
+30 SET Q=0
SET BWRES(N,"P")=0
SET BWRES(N,"T")=0
+31 FOR
SET Q=$ORDER(BWRES(N,Q))
IF 'Q
QUIT
Begin DoDot:2
+32 SET BWRES(N,"P")=BWRES(N,"P")+BWRES(N,Q,"P")
+33 SET BWRES(N,"T")=BWRES(N,"T")+BWRES(N,Q,"T")
End DoDot:2
End DoDot:1
+34 ;
+35 ;
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
+8 SET N=0
+9 FOR
SET N=$ORDER(BWRES(N))
IF 'N
QUIT
Begin DoDot:1
+10 SET M=0
SET (BWPN,X)=$PIECE(^BWPN(N,0),U)
+11 FOR
SET M=$ORDER(BWRES(N,M))
IF 'M
QUIT
Begin DoDot:2
+12 SET X=BWPN
+13 FOR I=0,1,2
Begin DoDot:3
+14 SET X=X_U_BWRES(N,M,I,"P")
+15 SET X=X_U_$JUSTIFY((BWRES(N,M,I,"P")*100/BWRES(N,M,"P")),1,0)
+16 SET X=X_U_BWRES(N,M,I,"T")
+17 SET X=X_U_$JUSTIFY((BWRES(N,M,I,"T")*100/BWRES(N,M,"T")),1,0)
End DoDot:3
+18 SET X=X_U_BWRES(N,M,"P")_U_BWRES(N,M,"T")_U_M
+19 SET BWRES("R",BWPN,M)=X
End DoDot:2
+20 ;--->
+21 ;---> NOW GET TOTALS FOR THIS PROCEDURE.
+22 NEW A,B,C,D,E,F
+23 SET (A,B,C,D,E,F,M)=0
+24 FOR
SET M=$ORDER(BWRES("R",BWPN,M))
IF 'M
QUIT
Begin DoDot:2
+25 SET Y=BWRES("R",BWPN,M)
+26 SET A=A+$PIECE(Y,U,2)
SET B=B+$PIECE(Y,U,4)
SET C=C+$PIECE(Y,U,6)
+27 SET D=D+$PIECE(Y,U,8)
SET E=E+$PIECE(Y,U,10)
SET F=F+$PIECE(Y,U,12)
End DoDot:2
+28 SET X=BWPN_U_A_U_$JUSTIFY(A*100/BWRES(N,"P"),1,0)
+29 SET X=X_U_B_U_$JUSTIFY(B*100/BWRES(N,"T"),1,0)
+30 SET X=X_U_C_U_$JUSTIFY(C*100/BWRES(N,"P"),1,0)
+31 SET X=X_U_D_U_$JUSTIFY(D*100/BWRES(N,"T"),1,0)
+32 SET X=X_U_E_U_$JUSTIFY(E*100/BWRES(N,"P"),1,0)
+33 SET X=X_U_F_U_$JUSTIFY(F*100/BWRES(N,"T"),1,0)
+34 SET X=X_U_BWRES(N,"P")_U_BWRES(N,"T")_U_"ALL"
+35 SET BWRES("R",BWPN,"ALL")=X
End DoDot:1
+36 QUIT
+37 ;
+38 ;
BWAGE(DFN,DATE,X) ;EP
+1 ;---> SET AGE CATEGORY.
+2 ;---> REQUIRED VARIABLES: DATE=DATE PATIENT RECEIVED THIS PROCEDURE.
+3 ;---> DFN, X=BWAGRG (AGE RANGE).
+4 ;---> IF NOT DISPLAY BY AGE, SET ALL BWAGE=1
+5 IF X=1
QUIT 1
+6 NEW AGE,Y,Z
+7 SET AGE=$PIECE($$AGEAT^BWUTL1(DFN,DATE),"y/o")
+8 ;---> RETURN 0 IF PATIENT'S AGE IS UNKNOWN.
+9 IF '+AGE
QUIT 0
+10 ;
+11 FOR I=1:1:$LENGTH(X,",")
SET Y=$PIECE($PIECE(X,",",I),"-",2)
IF AGE'>Y
QUIT
+12 SET Z=$PIECE($PIECE(X,",",I),"-")
+13 ;---> RETURN 0 IF PATIENT IS OUTSIDE DATE RANGE.
+14 IF (AGE<Z!(AGE>Y))
QUIT 0
+15 QUIT Y
+16 ; Return a result based on Mammography Assessment Fields
+17 ; Input: BWPCD = IEN to BW Procedure File
+18 ; Uses: Fields 12.02,12.03,12.04,12.05,12.06
+19 ; Result yields one of the following values:
+20 ; Normal - 0
+21 ; Abnormal - 1
+22 ; NO Result - 2
MPNORM(BWPCD) ;
+1 NEW RES,NORES,NORM,ABNORM,LP
+2 SET RES=""
SET NORES=2
SET NORM=0
SET ABNORM=1
+3 ; Check Negative Finding
+4 IF $$GET1^DIQ(9002086.1,BWPCD,12.02,"I")!($$GET1^DIQ(9002086.1,BWPCD,12.03,"I"))
QUIT NORM
+5 FOR LP=12.04,12.05,12.06
Begin DoDot:1
+6 SET RES=RES+$$GET1^DIQ(9002086.1,BWPCD,LP,"I")
End DoDot:1
+7 QUIT $SELECT('RES:NORES,1:ABNORM)
