- 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)
