BNIG.m

BNIG ; IHS/CMI/LAB - group entry for bni ;

 ;;1.0;BNI CPHD ACTIVITY DATASYSTEM;;DEC 20, 2006

 ;; ;

START ; Write Header

 D EOJ ; -- kill all vars before starting

 W:$D(IOF) @IOF

 F J=1:1:13 S X=$P($T(TEXT+J),";;",2) W !?80-$L(X)\2,X

 K X,J

START1 ;

 I '$O(^BNISITE(0)) W !!,"Site parameters have not been set up.  Please see the system manager." D PAUSE,EOJ Q

 W !!

 D GETSITE

 I BNISITE="" D EOJ Q

 D ADDQ

 I BNIADDQ="" G START1

AGR ;

 D FULL^VALM1

 W !!

MNTH ;

 S (BNIMNTH,BNIDATE,BNIYR)=""  ;,DIR(0)="DO^:"_DT_":EPTX",DIR("A")="Enter Date of Activity" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 S DIR(0)="S^1:JANUARY;2:FEBRUARY;3:MARCH;4:APRIL;5:MAY;6:JUNE;7:JULY;8:AUGUST;9:SEPTEMBER;10:OCTOBER;11:NOVEMBER;12:DECEMBER",DIR("A")="Enter the MONTH the activity took place" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) D PAUSE G EOJ

 S BNIMNTH=Y I $L(BNIMNTH)=1 S BNIMNTH="0"_BNIMNTH

YR ;

 S BNIYR=""

 S (BNIPER,BNIVDT)=""

 K DIR S DIR(0)="D^::EP",DIR("B")=$$FMTE^XLFDT(($E(DT,1,3)_"0000"))

 S DIR("A")="Enter Year"

 S DIR("?")="Enter the year the activity took place. E.g. 2006 or 06"

 D ^DIR KILL DIR

 I $D(DIRUT) D PAUSE G MNTH

 I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G YR

 S BNIYR=Y

 S BNIDATE=BNIYR,$E(BNIDATE,4,5)=BNIMNTH

 I BNIDATE>DT W !!,"Future dates are not allowed!",! G MNTH

 ;

ADDR ;

 K DIC S DIC(0)="EL",DIC="^BNIGROUP(",DLAYGO=90510.5,DIADD=1,X=BNIDATE

 S DIC("DR")=".02////"_DT_";.03////"_DUZ_";.06////"_DUZ(2)_";.07////"_DUZ(2)

 K DD,DO,D0 D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0

 I Y=-1 W !!,$C(7),$C(7),"CPHAD Group Record is NOT complete!!  Deleting Record.",! D PAUSE,EOJ Q

 ;update multiple of user last update/date edited

 S BNIGR=+Y

ADDR1 ;

 S DA=BNIGR,DDSFILE=90510.5,DR=$S($G(BNIADDQ):"[BNIA GROUP ENTRY]",1:"[BNI GROUP ENTRY]") D ^DDS

 I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***" D PAUSE,EOJ Q

 ;check record for completeness

 D CHECKREC

 I Q D  G:BNIA="E" ADDR1  D DELR,PAUSE,EOJ Q

 .S BNIA="" K DIR

 .S DIR(0)="S^E:Edit and complete the Group Record;D:Delete the Incomplete Group Record",DIR("A")="Do you wish to",DIR("B")="E" KILL DA D ^DIR KILL DIR

 .I $D(DIRUT) S BNIA="D"

 .S BNIA=Y

GROUP ;

 W !!,"I will now create an individual activity record for the following:"

 S X=0 F  S X=$O(^BNIGROUP(BNIGR,16,X)) Q:X'=+X  W !?5,$P(^VA(200,$P(^BNIGROUP(BNIGR,16,X,0),U),0),U)

 S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="Y" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) W !!,"No records created." D PAUSE,EOJ Q

 S BNIX=0 F  S BNIX=$O(^BNIGROUP(BNIGR,16,BNIX)) Q:BNIX'=+BNIX  D

 .S BNIPRV=$P(^BNIGROUP(BNIGR,16,BNIX,0),U)

 .W !,"Creating record for ",$P(^VA(200,BNIPRV,0),U)

 .K DIC S DIC(0)="EL",DIC="^BNIREC(",DLAYGO=90510,DIADD=1,X=BNIDATE

 .S DIC("DR")=".02////"_DT_";.03////"_DUZ_";.06////"_DUZ(2)_";.08////"_BNIPRV

 .K DD,DO,D0 D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0

 .I Y=-1 W !!,$C(7),$C(7),"Creating record for ",$P(^VA(200,BNIPRV,0),U)," failed!!  Deleting Record.",! D PAUSE,EOJ Q

 .;update multiple of user last update/date edited

 .S BNIR=+Y

 .S DIE="^BNIREC(",DA=BNIR,DR="1500///NOW",DR(2,90510.0115)=".02////^S X=DUZ" D ^DIE K DIE,DA,DR

 .F BNIZ=7,9,11:1:18 S $P(^BNIREC(BNIR,0),U,BNIZ)=$P(^BNIGROUP(BNIGR,0),U,BNIZ)

 .F BNIZ=1,2 I $P($G(^BNIGROUP(BNIGR,11)),U,BNIZ)]"" S $P(^BNIREC(BNIR,11),U,BNIZ)=$P(^BNIGROUP(BNIGR,0),U,BNIZ)

 .F BNIZ=1 I $P($G(^BNIGROUP(BNIGR,12)),U,BNIZ)]"" S $P(^BNIREC(BNIR,12),U,BNIZ)=$P(^BNIGROUP(BNIGR,12),U,BNIZ)

 .S BNIW=0 F  S BNIW=$O(^BNIGROUP(BNIGR,14,BNIW)) Q:BNIW'=+BNIW  D

 ..S ^BNIREC(BNIR,14,BNIW,0)=^BNIGROUP(BNIGR,14,BNIW,0)

 ..S ^BNIREC(BNIR,14,0)="^^"_BNIW_"^"_BNIW_"^"_DT_"^"

 .S DA=BNIR,DIK="^BNIREC(" D IX1^DIK

 W !,"Records created."

 D PAUSE

 D EOJ

 Q

 ;

EOJ ;EOJ CLEANUP

 D CLEAR^VALM1

 D EN^XBVK("BNI")

 Q

GETSITE ;

 S BNISITE=""

 W ! K DIC S DIC="^BNISITE(",DIC("A")="Enter your Site: ",DIC("B")=$P(^DIC(4,DUZ(2),0),U),DIC(0)="AEMQ" D ^DIC K DIC

 I Y=-1 Q

 S BNISITE=+Y

 Q

ADDQ ;

 S BNIADDQ=""

 W !

 K DIR

 S DIR(0)="Y",DIR("A")="Do you want to be prompted for Travel Time and Number Served",DIR("B")="N" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) Q

 S BNIADDQ=Y

 Q

DATE(D) ;

 Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)

 ;

 ;

TEXT ;

 ;;Computerized Public Health Activity (CPHAD) Group Data Entry

 ;;

 ;;***************************************

 ;;* Update CPHAD Group Activity Records *

 ;;***************************************

 ;;

 ;;This option is used to enter a GROUP Activity Record.

 ;;You will be asked to enter all information about the activity

 ;;including all persons who participated in the activity. 

 ;;When all information is entered a public health activity record

 ;;will be generated for each person who participated in the

 ;;group activity.

 ;;

 Q

SHT(G) ;EP - called from screenman screen

 I $G(G)="" Q ""

 NEW X

 S X=$O(^BNISHT("AA",G,1,0))

 I X,$D(^BNISHT(X,0)) Q $P(^BNISHT(X,0),U,1)

 Q ""

GHCPOST ;EP - called from screenman

 D REQ^DDSUTL(4,2,1,$S('$G(X):0,$P(^BNIGHC(X,0),U,3)=1:1,1:0)) ;require other if Other

 I 'X D PUT^DDSVAL(DIE,.DA,1101,"") ;empty out 1101 if not Other

 I X,'$P(^BNIGHC(X,0),U,3) D PUT^DDSVAL(DIE,.DA,1101,"")

 D UNED^DDSUTL(4,2,1,$S('$G(X):1,$P(^BNIGHC(X,0),U,3)=1:0,1:1)) ;don't allow field 7 if not other

 S BNISMGNC=X

 NEW Z

 S Z=$$GET^DDSVAL(DIE,.DA,.12)

 I Z="" D PUT^DDSVAL(DIE,.DA,.12,$$SHT(BNISMGNC))

 I Z]"" D

 .Q:$P(^BNISHT(Z,0),U,3)=BNISMGNC

 .D PUT^DDSVAL(DIE,.DA,.12,$$SHT(BNISMGNC))

 .Q

 D REFRESH^DDSUTL

 Q

SHTPOST ;EP - called from screenman

 D REQ^DDSUTL(6,2,1,$S('$G(X):0,$P(^BNISHT(X,0),U,5)=1:1,1:0)) ;require other if Other

 I 'X D PUT^DDSVAL(DIE,.DA,1102,"") ;empty out 1101 if not Other

 I X,'$P(^BNISHT(X,0),U,5) D PUT^DDSVAL(DIE,.DA,1102,"")

 D UNED^DDSUTL(6,2,1,$S('$G(X):1,$P(^BNISHT(X,0),U,5)=1:0,1:1)) ;don't allow field 8 if not other

 D REFRESH^DDSUTL

 Q

TOAPOST ;EP - called from screenman

 D REQ^DDSUTL(8,2,1,$S('$G(X):0,$P(^BNITOA(X,0),U,3)=1:1,1:0)) ;require other if Other

 I 'X D PUT^DDSVAL(DIE,.DA,1103,"") ;empty out 1101 if not Other

 I X,'$P(^BNITOA(X,0),U,3) D PUT^DDSVAL(DIE,.DA,1103,"")

 D UNED^DDSUTL(8,2,1,$S('$G(X):1,$P(^BNITOA(X,0),U,3)=1:0,1:1)) ;don't allow field 8 if not other

 D REFRESH^DDSUTL

 Q

GSPOST ;EP - called from screenman

 D REQ^DDSUTL(10,2,1,$S('$G(X):0,$P(^BNIGS(X,0),U,3)=1:1,1:0)) ;require other if Other

 I 'X D PUT^DDSVAL(DIE,.DA,1104,"") ;empty out 1101 if not Other

 I X,'$P(^BNIGS(X,0),U,3) D PUT^DDSVAL(DIE,.DA,1104,"")

 D UNED^DDSUTL(10,2,1,$S('$G(X):1,$P(^BNIGS(X,0),U,3)=1:0,1:1)) ;don't allow field 10 if not other

 D REFRESH^DDSUTL

 Q

ASPOST ;EP - called from screenman

 D REQ^DDSUTL(12,2,1,$S('$G(X):0,$P(^BNIAS(X,0),U,3)=1:1,1:0)) ;require other if Other

 I 'X D PUT^DDSVAL(DIE,.DA,.16,"") ;empty out 1101 if not Other

 I X,'$P(^BNIAS(X,0),U,3) D PUT^DDSVAL(DIE,.DA,.16,"")

 D UNED^DDSUTL(12,2,1,$S('$G(X):1,$P(^BNIAS(X,0),U,3)=1:0,1:1)) ;don't allow field 12 if not other

 D REFRESH^DDSUTL

 Q

SHTSCR(I) ;EP - called from screen on dd 90510 FIELD .12

 I '$G(BNISMGNC) Q 1

 I $P(^BNISHT(I,0),U,3)'=BNISMGNC Q 0

 Q 1

COMM(I) ;EP - called from screen on dd 90510 field .16

 I '$G(BNISITE) Q 1

 NEW Z,C

 S Z=$P($G(^BNISITE(BNISITE,0)),U,3)

 I 'Z Q 1

 S C=$P(^AUTTCOM(Y,0),U)

 I '$D(^ATXAX(Z,0)) Q 1

 I '$D(^ATXAX(Z,21,"B",C)) Q 0

 Q 1

CHECKREC ;

 S Q="" F F=.07,.09,.11,.12,.13 I $P(^BNIGROUP(BNIGR,0),U,+$P(F,".",2))="" D

 .W !,$P(^DD(90510,F,0),U)," is a required field and is missing." S Q=1

 I $P($G(^BNISITE(BNISITE,0)),U,2),$P(^BNIGROUP(BNIGR,0),U,15)="" D

 .W !,"ACTIVITY SETTING is required and is missing." S Q=1

 S X=$P(^BNIGROUP(BNIGR,0),U,11) I X,$P(^BNIGHC(X,0),U,3),$P($G(^BNIGROUP(BNIGR,11)),U,1)="" D

 .W !,"GENERAL HEALTH CONCERN is ",$P(^BNIGHC(X,0),U),!,"   and the text of GENERAL HEALTH CONCERN (OTHER) is missing." S Q=1

 S X=$P(^BNIGROUP(BNIGR,0),U,12) I X,$P(^BNISHT(X,0),U,5),$P($G(^BNIGROUP(BNIGR,11)),U,2)="" D

 .W !,"SPECIFIC HEALTH TOPIC is ",$P(^BNISHT(X,0),U),!,"   and the text of SPECIFIC HEALTH TOPIC (OTHER) is missing." S Q=1

 S X=$P(^BNIGROUP(BNIGR,0),U,13) I X,$P(^BNITOA(X,0),U,3),$P($G(^BNIGROUP(BNIGR,11)),U,3)="" D

 .W !,"TYPE OF ACTIVITY is ",$P(^BNITOA(X,0),U),!,"   and the text of TYPE OF ACTIVITY (OTHER) is missing." S Q=1

 S X=$P(^BNIGROUP(BNIGR,0),U,14) I X,$P(^BNIGS(X,0),U,3),$P($G(^BNIGROUP(BNIGR,12)),U,1)="" D

 .W !,"GROUP SERVED is ",$P(^BNIGS(X,0),U),!,"   and the text of GROUP SERVED (OTHER) is missing." S Q=1

 S X=$P(^BNIGROUP(BNIGR,0),U,15) I X,$P(^BNIAS(X,0),U,3),$P($G(^BNIGROUP(BNIGR,0)),U,16)="" D

 .W !,"ACTIVITY SETTING is ",$P(^BNIAS(X,0),U),!,"   and the COMMUNITY is missing." S Q=1

 I '$O(^BNIGROUP(BNIGR,16,0)) W !!,"You must enter at least one participating individual." S Q=1

 Q

DELR ;

 S DA=BNIGR,DIK="^BNIGROUP(" D ^DIK K DIK,DA

 Q

PAUSE ;EP

 S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q

BNIG      ; IHS/CMI/LAB - group entry for bni ;

 +1       ;;1.0;BNI CPHD ACTIVITY DATASYSTEM;;DEC 20, 2006

 +2       ;; ;

START     ; Write Header

 +1       ; -- kill all vars before starting

           DO EOJ

 +2        IF $DATA(IOF)

               WRITE @IOF

 +3        FOR J=1:1:13

               SET X=$PIECE($TEXT(TEXT+J),";;",2)

               WRITE !?80-$LENGTH(X)\2,X

 +4        KILL X,J

START1    ;

 +1        IF '$ORDER(^BNISITE(0))

               WRITE !!,"Site parameters have not been set up.  Please see the system manager."

               DO PAUSE

               DO EOJ

               QUIT 

 +2        WRITE !!

 +3        DO GETSITE

 +4        IF BNISITE=""

               DO EOJ

               QUIT 

 +5        DO ADDQ

 +6        IF BNIADDQ=""

               GOTO START1

AGR       ;

 +1        DO FULL^VALM1

 +2        WRITE !!

MNTH      ;

 +1       ;,DIR(0)="DO^:"_DT_":EPTX",DIR("A")="Enter Date of Activity" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

           SET (BNIMNTH,BNIDATE,BNIYR)=""

 +2        SET DIR(0)="S^1:JANUARY;2:FEBRUARY;3:MARCH;4:APRIL;5:MAY;6:JUNE;7:JULY;8:AUGUST;9:SEPTEMBER;10:OCTOBER;11:NOVEMBER;12:DECEMBER"

           SET DIR("A")="Enter the MONTH the activity took place"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               DO PAUSE

               GOTO EOJ

 +4        SET BNIMNTH=Y

           IF $LENGTH(BNIMNTH)=1

               SET BNIMNTH="0"_BNIMNTH

YR        ;

 +1        SET BNIYR=""

 +2        SET (BNIPER,BNIVDT)=""

 +3        KILL DIR

           SET DIR(0)="D^::EP"

           SET DIR("B")=$$FMTE^XLFDT(($EXTRACT(DT,1,3)_"0000"))

 +4        SET DIR("A")="Enter Year"

 +5        SET DIR("?")="Enter the year the activity took place. E.g. 2006 or 06"

 +6        DO ^DIR

           KILL DIR

 +7        IF $DATA(DIRUT)

               DO PAUSE

               GOTO MNTH

 +8        IF $EXTRACT(Y,4,7)'="0000"

               WRITE !!,"Please enter a year only!",!

               GOTO YR

 +9        SET BNIYR=Y

 +10       SET BNIDATE=BNIYR

           SET $EXTRACT(BNIDATE,4,5)=BNIMNTH

 +11       IF BNIDATE>DT

               WRITE !!,"Future dates are not allowed!",!

               GOTO MNTH

 +12      ;

ADDR      ;

 +1        KILL DIC

           SET DIC(0)="EL"

           SET DIC="^BNIGROUP("

           SET DLAYGO=90510.5

           SET DIADD=1

           SET X=BNIDATE

 +2        SET DIC("DR")=".02////"_DT_";.03////"_DUZ_";.06////"_DUZ(2)_";.07////"_DUZ(2)

 +3        KILL DD,DO,D0

           DO FILE^DICN

           KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0

 +4        IF Y=-1

               WRITE !!,$CHAR(7),$CHAR(7),"CPHAD Group Record is NOT complete!!  Deleting Record.",!

               DO PAUSE

               DO EOJ

               QUIT 

 +5       ;update multiple of user last update/date edited

 +6        SET BNIGR=+Y

ADDR1     ;

 +1        SET DA=BNIGR

           SET DDSFILE=90510.5

           SET DR=$SELECT($GET(BNIADDQ):"[BNIA GROUP ENTRY]",1:"[BNI GROUP ENTRY]")

           DO ^DDS

 +2        IF $DATA(DIMSG)

               WRITE !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***"

               DO PAUSE

               DO EOJ

               QUIT 

 +3       ;check record for completeness

 +4        DO CHECKREC

 +5        IF Q

               Begin DoDot:1

 +6                SET BNIA=""

                   KILL DIR

 +7                SET DIR(0)="S^E:Edit and complete the Group Record;D:Delete the Incomplete Group Record"

                   SET DIR("A")="Do you wish to"

                   SET DIR("B")="E"

                   KILL DA

                   DO ^DIR

                   KILL DIR

 +8                IF $DATA(DIRUT)

                       SET BNIA="D"

 +9                SET BNIA=Y

               End DoDot:1

               IF BNIA="E"

                   GOTO ADDR1

               DO DELR

               DO PAUSE

               DO EOJ

               QUIT 

GROUP     ;

 +1        WRITE !!,"I will now create an individual activity record for the following:"

 +2        SET X=0

           FOR 

               SET X=$ORDER(^BNIGROUP(BNIGR,16,X))

               IF X'=+X

                   QUIT 

               WRITE !?5,$PIECE(^VA(200,$PIECE(^BNIGROUP(BNIGR,16,X,0),U),0),U)

 +3        SET DIR(0)="Y"

           SET DIR("A")="Do you wish to continue"

           SET DIR("B")="Y"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               WRITE !!,"No records created."

               DO PAUSE

               DO EOJ

               QUIT 

 +5        SET BNIX=0

           FOR 

               SET BNIX=$ORDER(^BNIGROUP(BNIGR,16,BNIX))

               IF BNIX'=+BNIX

                   QUIT 

               Begin DoDot:1

 +6                SET BNIPRV=$PIECE(^BNIGROUP(BNIGR,16,BNIX,0),U)

 +7                WRITE !,"Creating record for ",$PIECE(^VA(200,BNIPRV,0),U)

 +8                KILL DIC

                   SET DIC(0)="EL"

                   SET DIC="^BNIREC("

                   SET DLAYGO=90510

                   SET DIADD=1

                   SET X=BNIDATE

 +9                SET DIC("DR")=".02////"_DT_";.03////"_DUZ_";.06////"_DUZ(2)_";.08////"_BNIPRV

 +10               KILL DD,DO,D0

                   DO FILE^DICN

                   KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0

 +11               IF Y=-1

                       WRITE !!,$CHAR(7),$CHAR(7),"Creating record for ",$PIECE(^VA(200,BNIPRV,0),U)," failed!!  Deleting Record.",!

                       DO PAUSE

                       DO EOJ

                       QUIT 

 +12      ;update multiple of user last update/date edited

 +13               SET BNIR=+Y

 +14               SET DIE="^BNIREC("

                   SET DA=BNIR

                   SET DR="1500///NOW"

                   SET DR(2,90510.0115)=".02////^S X=DUZ"

                   DO ^DIE

                   KILL DIE,DA,DR

 +15               FOR BNIZ=7,9,11:1:18

                       SET $PIECE(^BNIREC(BNIR,0),U,BNIZ)=$PIECE(^BNIGROUP(BNIGR,0),U,BNIZ)

 +16               FOR BNIZ=1,2

                       IF $PIECE($GET(^BNIGROUP(BNIGR,11)),U,BNIZ)]""

                           SET $PIECE(^BNIREC(BNIR,11),U,BNIZ)=$PIECE(^BNIGROUP(BNIGR,0),U,BNIZ)

 +17               FOR BNIZ=1

                       IF $PIECE($GET(^BNIGROUP(BNIGR,12)),U,BNIZ)]""

                           SET $PIECE(^BNIREC(BNIR,12),U,BNIZ)=$PIECE(^BNIGROUP(BNIGR,12),U,BNIZ)

 +18               SET BNIW=0

                   FOR 

                       SET BNIW=$ORDER(^BNIGROUP(BNIGR,14,BNIW))

                       IF BNIW'=+BNIW

                           QUIT 

                       Begin DoDot:2

 +19                       SET ^BNIREC(BNIR,14,BNIW,0)=^BNIGROUP(BNIGR,14,BNIW,0)

 +20                       SET ^BNIREC(BNIR,14,0)="^^"_BNIW_"^"_BNIW_"^"_DT_"^"

                       End DoDot:2

 +21               SET DA=BNIR

                   SET DIK="^BNIREC("

                   DO IX1^DIK

               End DoDot:1

 +22       WRITE !,"Records created."

 +23       DO PAUSE

 +24       DO EOJ

 +25       QUIT 

 +26      ;

EOJ       ;EOJ CLEANUP

 +1        DO CLEAR^VALM1

 +2        DO EN^XBVK("BNI")

 +3        QUIT 

GETSITE   ;

 +1        SET BNISITE=""

 +2        WRITE !

           KILL DIC

           SET DIC="^BNISITE("

           SET DIC("A")="Enter your Site: "

           SET DIC("B")=$PIECE(^DIC(4,DUZ(2),0),U)

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC

 +3        IF Y=-1

               QUIT 

 +4        SET BNISITE=+Y

 +5        QUIT 

ADDQ      ;

 +1        SET BNIADDQ=""

 +2        WRITE !

 +3        KILL DIR

 +4        SET DIR(0)="Y"

           SET DIR("A")="Do you want to be prompted for Travel Time and Number Served"

           SET DIR("B")="N"

           KILL DA

           DO ^DIR

           KILL DIR

 +5        IF $DATA(DIRUT)

               QUIT 

 +6        SET BNIADDQ=Y

 +7        QUIT 

DATE(D)   ;

 +1        QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)

 +2       ;

 +3       ;

TEXT      ;

 +1       ;;Computerized Public Health Activity (CPHAD) Group Data Entry

 +2       ;;

 +3       ;;***************************************

 +4       ;;* Update CPHAD Group Activity Records *

 +5       ;;***************************************

 +6       ;;

 +7       ;;This option is used to enter a GROUP Activity Record.

 +8       ;;You will be asked to enter all information about the activity

 +9       ;;including all persons who participated in the activity. 

 +10      ;;When all information is entered a public health activity record

 +11      ;;will be generated for each person who participated in the

 +12      ;;group activity.

 +13      ;;

 +14       QUIT 

SHT(G)    ;EP - called from screenman screen

 +1        IF $GET(G)=""

               QUIT ""

 +2        NEW X

 +3        SET X=$ORDER(^BNISHT("AA",G,1,0))

 +4        IF X

               IF $DATA(^BNISHT(X,0))

                   QUIT $PIECE(^BNISHT(X,0),U,1)

 +5        QUIT ""

GHCPOST   ;EP - called from screenman

 +1       ;require other if Other

           DO REQ^DDSUTL(4,2,1,$SELECT('$GET(X):0,$PIECE(^BNIGHC(X,0),U,3)=1:1,1:0))

 +2       ;empty out 1101 if not Other

           IF 'X

               DO PUT^DDSVAL(DIE,.DA,1101,"")

 +3        IF X

               IF '$PIECE(^BNIGHC(X,0),U,3)

                   DO PUT^DDSVAL(DIE,.DA,1101,"")

 +4       ;don't allow field 7 if not other

           DO UNED^DDSUTL(4,2,1,$SELECT('$GET(X):1,$PIECE(^BNIGHC(X,0),U,3)=1:0,1:1))

 +5        SET BNISMGNC=X

 +6        NEW Z

 +7        SET Z=$$GET^DDSVAL(DIE,.DA,.12)

 +8        IF Z=""

               DO PUT^DDSVAL(DIE,.DA,.12,$$SHT(BNISMGNC))

 +9        IF Z]""

               Begin DoDot:1

 +10               IF $PIECE(^BNISHT(Z,0),U,3)=BNISMGNC

                       QUIT 

 +11               DO PUT^DDSVAL(DIE,.DA,.12,$$SHT(BNISMGNC))

 +12               QUIT 

               End DoDot:1

 +13       DO REFRESH^DDSUTL

 +14       QUIT 

SHTPOST   ;EP - called from screenman

 +1       ;require other if Other

           DO REQ^DDSUTL(6,2,1,$SELECT('$GET(X):0,$PIECE(^BNISHT(X,0),U,5)=1:1,1:0))

 +2       ;empty out 1101 if not Other

           IF 'X

               DO PUT^DDSVAL(DIE,.DA,1102,"")

 +3        IF X

               IF '$PIECE(^BNISHT(X,0),U,5)

                   DO PUT^DDSVAL(DIE,.DA,1102,"")

 +4       ;don't allow field 8 if not other

           DO UNED^DDSUTL(6,2,1,$SELECT('$GET(X):1,$PIECE(^BNISHT(X,0),U,5)=1:0,1:1))

 +5        DO REFRESH^DDSUTL

 +6        QUIT 

TOAPOST   ;EP - called from screenman

 +1       ;require other if Other

           DO REQ^DDSUTL(8,2,1,$SELECT('$GET(X):0,$PIECE(^BNITOA(X,0),U,3)=1:1,1:0))

 +2       ;empty out 1101 if not Other

           IF 'X

               DO PUT^DDSVAL(DIE,.DA,1103,"")

 +3        IF X

               IF '$PIECE(^BNITOA(X,0),U,3)

                   DO PUT^DDSVAL(DIE,.DA,1103,"")

 +4       ;don't allow field 8 if not other

           DO UNED^DDSUTL(8,2,1,$SELECT('$GET(X):1,$PIECE(^BNITOA(X,0),U,3)=1:0,1:1))

 +5        DO REFRESH^DDSUTL

 +6        QUIT 

GSPOST    ;EP - called from screenman

 +1       ;require other if Other

           DO REQ^DDSUTL(10,2,1,$SELECT('$GET(X):0,$PIECE(^BNIGS(X,0),U,3)=1:1,1:0))

 +2       ;empty out 1101 if not Other

           IF 'X

               DO PUT^DDSVAL(DIE,.DA,1104,"")

 +3        IF X

               IF '$PIECE(^BNIGS(X,0),U,3)

                   DO PUT^DDSVAL(DIE,.DA,1104,"")

 +4       ;don't allow field 10 if not other

           DO UNED^DDSUTL(10,2,1,$SELECT('$GET(X):1,$PIECE(^BNIGS(X,0),U,3)=1:0,1:1))

 +5        DO REFRESH^DDSUTL

 +6        QUIT 

ASPOST    ;EP - called from screenman

 +1       ;require other if Other

           DO REQ^DDSUTL(12,2,1,$SELECT('$GET(X):0,$PIECE(^BNIAS(X,0),U,3)=1:1,1:0))

 +2       ;empty out 1101 if not Other

           IF 'X

               DO PUT^DDSVAL(DIE,.DA,.16,"")

 +3        IF X

               IF '$PIECE(^BNIAS(X,0),U,3)

                   DO PUT^DDSVAL(DIE,.DA,.16,"")

 +4       ;don't allow field 12 if not other

           DO UNED^DDSUTL(12,2,1,$SELECT('$GET(X):1,$PIECE(^BNIAS(X,0),U,3)=1:0,1:1))

 +5        DO REFRESH^DDSUTL

 +6        QUIT 

SHTSCR(I) ;EP - called from screen on dd 90510 FIELD .12

 +1        IF '$GET(BNISMGNC)

               QUIT 1

 +2        IF $PIECE(^BNISHT(I,0),U,3)'=BNISMGNC

               QUIT 0

 +3        QUIT 1

COMM(I)   ;EP - called from screen on dd 90510 field .16

 +1        IF '$GET(BNISITE)

               QUIT 1

 +2        NEW Z,C

 +3        SET Z=$PIECE($GET(^BNISITE(BNISITE,0)),U,3)

 +4        IF 'Z

               QUIT 1

 +5        SET C=$PIECE(^AUTTCOM(Y,0),U)

 +6        IF '$DATA(^ATXAX(Z,0))

               QUIT 1

 +7        IF '$DATA(^ATXAX(Z,21,"B",C))

               QUIT 0

 +8        QUIT 1

CHECKREC  ;

 +1        SET Q=""

           FOR F=.07,.09,.11,.12,.13

               IF $PIECE(^BNIGROUP(BNIGR,0),U,+$PIECE(F,".",2))=""

                   Begin DoDot:1

 +2                    WRITE !,$PIECE(^DD(90510,F,0),U)," is a required field and is missing."

                       SET Q=1

                   End DoDot:1

 +3        IF $PIECE($GET(^BNISITE(BNISITE,0)),U,2)

               IF $PIECE(^BNIGROUP(BNIGR,0),U,15)=""

                   Begin DoDot:1

 +4                    WRITE !,"ACTIVITY SETTING is required and is missing."

                       SET Q=1

                   End DoDot:1

 +5        SET X=$PIECE(^BNIGROUP(BNIGR,0),U,11)

           IF X

               IF $PIECE(^BNIGHC(X,0),U,3)

                   IF $PIECE($GET(^BNIGROUP(BNIGR,11)),U,1)=""

                       Begin DoDot:1

 +6                        WRITE !,"GENERAL HEALTH CONCERN is ",$PIECE(^BNIGHC(X,0),U),!,"   and the text of GENERAL HEALTH CONCERN (OTHER) is missing."

                           SET Q=1

                       End DoDot:1

 +7        SET X=$PIECE(^BNIGROUP(BNIGR,0),U,12)

           IF X

               IF $PIECE(^BNISHT(X,0),U,5)

                   IF $PIECE($GET(^BNIGROUP(BNIGR,11)),U,2)=""

                       Begin DoDot:1

 +8                        WRITE !,"SPECIFIC HEALTH TOPIC is ",$PIECE(^BNISHT(X,0),U),!,"   and the text of SPECIFIC HEALTH TOPIC (OTHER) is missing."

                           SET Q=1

                       End DoDot:1