BWCVD.m

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