BWCVD ;IHS/CIM/THL/CIA - WISE WOMEN'S PROJECT;10-Mar-2003 13:39;PLS
;;2.0;WOMEN'S HEALTH;**3,5,7,8**;MAY 16, 1996
;
EN D EN1
EXIT ;EP;
K BWCVD,BWQUIT,BWPCDDA,BWTYPE,BWPCDN,BWX
D KILLALL^BWUTL8
Q
EN1 ;
D EXIT
D SETVARS^BWUTL5
N ERROR
F D PATIENT Q:$D(BWQUIT)
Q
PATIENT ;EP
D TITLE^BWUTL5("Add/Edit CVD Patient Case Data")
PATIENT1 ;EP
;---> TO AVOID @IOF AND TITLE.
;---> SELECT PATIENT.
N Y
W !!," Select the patient you wish to add or edit."
D PATLKUP^BWUTL8(.Y,"ADD")
I Y<0 S BWQUIT=1 Q
S BWDFN=+Y
D CDCID(BWDFN)
D ADDEDIT
Q
ADDEDIT ;
K DIR
S DIR(0)="SO^1:Add New Procedure;2:Edit Existing Procedure"
S DIR("A")="Which function"
W !
D ^DIR
K DIR
Q:Y<1
I Y=1 D ADD Q
I Y=2 D LOOKUP
Q
ADD ;ADD A PROCEDURE
S DIR(0)="SO^1:Enrollment;2:Annual Follow-up"
S DIR("A")="Which type of Visit"
W !
D ^DIR
K DIR
Q:Y<1
S BWTYPE=Y
I BWTYPE=1 D Q:$G(BWPCDDA)
.S BWX=0
.F S BWX=$O(^BWPCD("C",BWDFN,BWX)) Q:'BWX!$G(BWPCDDA) D
..S X=+$G(^BWPCD(BWX,4))
..Q:X'=1
..W !,$P(^DPT(BWDFN,0),U)," Enrolled in Wise Women Project on "
..S Y=$P($G(^BWPCD(BWX,4)),U,2)
..X ^DD("DD")
..W Y
..H 3
..S BWPCDDA=BWX
..D EDIT
ADD1 ;K DIR
;S DIR(0)="DO"
;S DIR("A")="WW Enrollment Date"
;S Y=DT
;X ^DD("DD")
;S DIR("B")=Y
;D ^DIR
;K DIR
;Q:'Y
;S BWDATE=Y
S BWPCDN=$O(^BWPN("B","WISE WOMAN",0))
I 'BWPCDN D Q
.W !,"The WISE WOMAN procedure is missing."
.W !,"Contact the computer department."
D DATECHK^BWPROC Q:BWPOP
S BWACC=$$ACCSSN^BWUTL5(BWPCDN)
I BWACC']"" D Q
.W !!?5,*7,"Unable to generate accession number. Contact your site manager."
.S ERROR=-1 D DIRZ^BWUTL3
;K DA,DR,DIE
N DRSTR
S DRSTR=".02////"_BWDFN_";.03////"_BWPCDT_";.04////"_BWPCDN_";.1////"_$G(DUZ(2))_";.18////"_DUZ_";.19///"_$$DT^XLFDT_";.34////"_$G(DUZ(2))_";4.01////"_BWTYPE_";4.02////"_BWPCDT_";.12////"_BWPCDT_";4.33////1"
D FILE^BWFMAN(9002086.1,DRSTR,"ML",BWACC,9002086,.Y)
;S DIC="^BWPCD("
;S DIC(0)="L"
;S DIC("DR")=".02////"_BWDFN_";.03////"_BWDATE_";4.01////"_BWTYPE_";4.02////"_BWDATE_";.12////"_BWDATE_";4.33////1"
;D FILE^DICN
;K DIC
S BWPCDDA=+Y
I BWPCDDA=-1 D Q
.W !!?5,*7,"Unable to create new procedure. Contact your site manager."
.S ERROR=-1 D DIRZ^BWUTL3
EDIT D SCREEN(BWPCDDA)
Q
LOOKUP ;LOOKUP EXISTING WW PROCEDURE
S (BWX,X)=0
F S BWX=$O(^BWPCD("C",BWDFN,BWX)) Q:'BWX!X D
.I +$G(^BWPCD(BWX,4))=1 S X=1 Q
I X'=1 D Q
.W !,$P(^DPT(BWDFN,0),U)," is not Enrolled in Wise Women Project."
.W !,"She will now be enrolled."
.H 3
.S BWTYPE=1
.D ADD1
S X=BWDFN
S D="C"
S DIC="^BWPCD("
S DIC(0)="EQZ"
S DIC("S")="I $E(^(0),1,2)=""WW"",+$G(^(4))'=3"
D IX^DIC
Q:Y<1
D SCREEN(+Y)
Q
;
SCREEN(BWPCDDA) ;EP
;---> EDIT PATIENT CASE DATA WITH SCREENMAN.
;---> REQUIRED VARIABLES: BWDFN=DFN OF PATIENT.
N DR,DIR,STATUS
S DR="[BW CVD PAGE 1]"
D DDS^BWFMAN(9002086.1,DR,BWPCDDA,"","",.BWQUIT)
S STATUS=+$$GET1^DIQ(9002086.1,BWPCDDA,4.33,"I")
I STATUS'=2 D
.W !,"Do you wish to CLOSE this procedure?"
.S DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR W !
.I Y D
..D DIE^BWFMAN(9002086.1,"4.33////2",BWPCDDA,.BWPOP)
.E I 'STATUS D
..D DIE^BWFMAN(9002086.1,"4.33////1",BWPCDDA,.BWPOP)
Q
Q:BWPOP
K DIR
W !,"Do you wish to PRINT this patient's Case Data?"
S DIR(0)="Y"
S DIR("B")="NO"
D ^DIR
K DIR
W !
D:Y PRTCASE^BWPATP(BWDFN)
Q
;
CDCID(BWDFN) ;
;---> ASSIGN A CDCID# TO THIS PATIENT.
N X S X=$$CDCID^BWUTL5(BWDFN,DUZ(2))
Q:X']""
D DIE^BWFMAN(9002086,".2////"_X,BWDFN,.BWPOP)
Q
NAV(DA) ;EP;TO CALCULATE THE AVERAGE NUTRITION SCORE
Q:'$G(DA)
N X,Y,Z,J
S X=$G(^BWPCD(DA,8))
S Y=0
F J=1:1:5 S:$P(X,U,J)'=99 Y=Y+$P(X,U,J)
Q:'Y 0
S Z=0
F J=1:1:5 S:$P(X,U,J)&($P(X,U,J)'=99) Z=Z+1
Q:'Z 0
S SCORE=$E(Y/Z,1,4)
Q SCORE
PAV(DA) ;EP;TO CALCULATE THE AVERAGE PHYSICAL ACTIVITY SCORE
Q:'$G(DA)
N X,Y,Z,J
S X=$G(^BWPCD(DA,6))
S Y=0
F J=1:1:8 S:$P(X,U,J)'=99 Y=Y+$P(X,U,J)
Q:'Y 0
S Z=0
F J=1:1:8 S:$P(X,U,J)&($P(X,U,J)'=99) Z=Z+1
Q:'Z 0
S SCORE=$E(Y/Z,1,4)
Q SCORE
BWCVD ;IHS/CIM/THL/CIA - WISE WOMEN'S PROJECT;10-Mar-2003 13:39;PLS
+1 ;;2.0;WOMEN'S HEALTH;**3,5,7,8**;MAY 16, 1996
+2 ;
EN DO EN1
EXIT ;EP;
+1 KILL BWCVD,BWQUIT,BWPCDDA,BWTYPE,BWPCDN,BWX
+2 DO KILLALL^BWUTL8
+3 QUIT
EN1 ;
+1 DO EXIT
+2 DO SETVARS^BWUTL5
+3 NEW ERROR
+4 FOR
DO PATIENT
IF $DATA(BWQUIT)
QUIT
+5 QUIT
PATIENT ;EP
+1 DO TITLE^BWUTL5("Add/Edit CVD Patient Case Data")
PATIENT1 ;EP
+1 ;---> TO AVOID @IOF AND TITLE.
+2 ;---> SELECT PATIENT.
+3 NEW Y
+4 WRITE !!," Select the patient you wish to add or edit."
+5 DO PATLKUP^BWUTL8(.Y,"ADD")
+6 IF Y<0
SET BWQUIT=1
QUIT
+7 SET BWDFN=+Y
+8 DO CDCID(BWDFN)
+9 DO ADDEDIT
+10 QUIT
ADDEDIT ;
+1 KILL DIR
+2 SET DIR(0)="SO^1:Add New Procedure;2:Edit Existing Procedure"
+3 SET DIR("A")="Which function"
+4 WRITE !
+5 DO ^DIR
+6 KILL DIR
+7 IF Y<1
QUIT
+8 IF Y=1
DO ADD
QUIT
+9 IF Y=2
DO LOOKUP
+10 QUIT
ADD ;ADD A PROCEDURE
+1 SET DIR(0)="SO^1:Enrollment;2:Annual Follow-up"
+2 SET DIR("A")="Which type of Visit"
+3 WRITE !
+4 DO ^DIR
+5 KILL DIR
+6 IF Y<1
QUIT
+7 SET BWTYPE=Y
+8 IF BWTYPE=1
Begin DoDot:1
+9 SET BWX=0
+10 FOR
SET BWX=$ORDER(^BWPCD("C",BWDFN,BWX))
IF 'BWX!$GET(BWPCDDA)
QUIT
Begin DoDot:2
+11 SET X=+$GET(^BWPCD(BWX,4))
+12 IF X'=1
QUIT
+13 WRITE !,$PIECE(^DPT(BWDFN,0),U)," Enrolled in Wise Women Project on "
+14 SET Y=$PIECE($GET(^BWPCD(BWX,4)),U,2)
+15 XECUTE ^DD("DD")
+16 WRITE Y
+17 HANG 3
+18 SET BWPCDDA=BWX
+19 DO EDIT
End DoDot:2
End DoDot:1
IF $GET(BWPCDDA)
QUIT
ADD1 ;K DIR
+1 ;S DIR(0)="DO"
+2 ;S DIR("A")="WW Enrollment Date"
+3 ;S Y=DT
+4 ;X ^DD("DD")
+5 ;S DIR("B")=Y
+6 ;D ^DIR
+7 ;K DIR
+8 ;Q:'Y
+9 ;S BWDATE=Y
+10 SET BWPCDN=$ORDER(^BWPN("B","WISE WOMAN",0))
+11 IF 'BWPCDN
Begin DoDot:1
+12 WRITE !,"The WISE WOMAN procedure is missing."
+13 WRITE !,"Contact the computer department."
End DoDot:1
QUIT
+14 DO DATECHK^BWPROC
IF BWPOP
QUIT
+15 SET BWACC=$$ACCSSN^BWUTL5(BWPCDN)
+16 IF BWACC']""
Begin DoDot:1
+17 WRITE !!?5,*7,"Unable to generate accession number. Contact your site manager."
+18 SET ERROR=-1
DO DIRZ^BWUTL3
End DoDot:1
QUIT
+19 ;K DA,DR,DIE
+20 NEW DRSTR
+21 SET DRSTR=".02////"_BWDFN_";.03////"_BWPCDT_";.04////"_BWPCDN_";.1////"_$GET(DUZ(2))_";.18////"_DUZ_";.19///"_$$DT^XLFDT_";.34////"_$G(DUZ(2))_";4.01////"_BWTYPE_";4.02////"_BWPCDT_";.12////"_BWPCDT_";4.33////1"
+22 DO FILE^BWFMAN(9002086.1,DRSTR,"ML",BWACC,9002086,.Y)
+23 ;S DIC="^BWPCD("
+24 ;S DIC(0)="L"
+25 ;S DIC("DR")=".02////"_BWDFN_";.03////"_BWDATE_";4.01////"_BWTYPE_";4.02////"_BWDATE_";.12////"_BWDATE_";4.33////1"
+26 ;D FILE^DICN
+27 ;K DIC
+28 SET BWPCDDA=+Y
+29 IF BWPCDDA=-1
Begin DoDot:1
+30 WRITE !!?5,*7,"Unable to create new procedure. Contact your site manager."
+31 SET ERROR=-1
DO DIRZ^BWUTL3
End DoDot:1
QUIT
EDIT DO SCREEN(BWPCDDA)
+1 QUIT
LOOKUP ;LOOKUP EXISTING WW PROCEDURE
+1 SET (BWX,X)=0
+2 FOR
SET BWX=$ORDER(^BWPCD("C",BWDFN,BWX))
IF 'BWX!X
QUIT
Begin DoDot:1
+3 IF +$GET(^BWPCD(BWX,4))=1
SET X=1
QUIT
End DoDot:1
+4 IF X'=1
Begin DoDot:1
+5 WRITE !,$PIECE(^DPT(BWDFN,0),U)," is not Enrolled in Wise Women Project."
+6 WRITE !,"She will now be enrolled."
+7 HANG 3
+8 SET BWTYPE=1
+9 DO ADD1
End DoDot:1
QUIT
+10 SET X=BWDFN
+11 SET D="C"
+12 SET DIC="^BWPCD("
+13 SET DIC(0)="EQZ"
+14 SET DIC("S")="I $E(^(0),1,2)=""WW"",+$G(^(4))'=3"
+15 DO IX^DIC
+16 IF Y<1
QUIT
+17 DO SCREEN(+Y)
+18 QUIT
+19 ;
SCREEN(BWPCDDA) ;EP
+1 ;---> EDIT PATIENT CASE DATA WITH SCREENMAN.
+2 ;---> REQUIRED VARIABLES: BWDFN=DFN OF PATIENT.
+3 NEW DR,DIR,STATUS
+4 SET DR="[BW CVD PAGE 1]"
+5 DO DDS^BWFMAN(9002086.1,DR,BWPCDDA,"","",.BWQUIT)
+6 SET STATUS=+$$GET1^DIQ(9002086.1,BWPCDDA,4.33,"I")
+7 IF STATUS'=2
Begin DoDot:1
+8 WRITE !,"Do you wish to CLOSE this procedure?"
+9 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
WRITE !
+10 IF Y
Begin DoDot:2
+11 DO DIE^BWFMAN(9002086.1,"4.33////2",BWPCDDA,.BWPOP)
End DoDot:2
+12 IF '$TEST
IF 'STATUS
Begin DoDot:2
+13 DO DIE^BWFMAN(9002086.1,"4.33////1",BWPCDDA,.BWPOP)
End DoDot:2
End DoDot:1
+14 QUIT
+15 IF BWPOP
QUIT
+16 KILL DIR
+17 WRITE !,"Do you wish to PRINT this patient's Case Data?"
+18 SET DIR(0)="Y"
+19 SET DIR("B")="NO"
+20 DO ^DIR
+21 KILL DIR
+22 WRITE !
+23 IF Y
DO PRTCASE^BWPATP(BWDFN)
+24 QUIT
+25 ;
CDCID(BWDFN) ;
+1 ;---> ASSIGN A CDCID# TO THIS PATIENT.
+2 NEW X
SET X=$$CDCID^BWUTL5(BWDFN,DUZ(2))
+3 IF X']""
QUIT
+4 DO DIE^BWFMAN(9002086,".2////"_X,BWDFN,.BWPOP)
+5 QUIT
NAV(DA) ;EP;TO CALCULATE THE AVERAGE NUTRITION SCORE
+1 IF '$GET(DA)
QUIT
+2 NEW X,Y,Z,J
+3 SET X=$GET(^BWPCD(DA,8))
+4 SET Y=0
+5 FOR J=1:1:5
IF $PIECE(X,U,J)'=99
SET Y=Y+$PIECE(X,U,J)
+6 IF 'Y
QUIT 0
+7 SET Z=0
+8 FOR J=1:1:5
IF $PIECE(X,U,J)&($PIECE(X,U,J)'=99)
SET Z=Z+1
+9 IF 'Z
QUIT 0
+10 SET SCORE=$EXTRACT(Y/Z,1,4)
+11 QUIT SCORE
PAV(DA) ;EP;TO CALCULATE THE AVERAGE PHYSICAL ACTIVITY SCORE
+1 IF '$GET(DA)
QUIT
+2 NEW X,Y,Z,J
+3 SET X=$GET(^BWPCD(DA,6))
+4 SET Y=0
+5 FOR J=1:1:8
IF $PIECE(X,U,J)'=99
SET Y=Y+$PIECE(X,U,J)
+6 IF 'Y
QUIT 0
+7 SET Z=0
+8 FOR J=1:1:8
IF $PIECE(X,U,J)&($PIECE(X,U,J)'=99)
SET Z=Z+1
+9 IF 'Z
QUIT 0
+10 SET SCORE=$EXTRACT(Y/Z,1,4)
+11 QUIT SCORE
