BNIE ; IHS/CMI/LAB - Data 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:11 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 WHICH
I BNIPRV="" D EOJ Q
D ADDQ
I BNIADDQ="" G START1
D EN,FULL^VALM1,EXIT
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
WHICH ;
S BNIPRV=""
D ^XBFMK
W ! K DIC S DIC=200,DIC(0)="AEMQ",DIC("A")="Enter Person who Performed the Activity: ",DIC("B")=$P(^VA(200,DUZ,0),U) D ^DIC K DIC
I Y=-1 Q
S BNIPRV=+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
EN ; EP -- main entry point for BNI UPDATE ACTIVITY RECORDS
S VALMCC=1
D EN^VALM("BNI UPDATE ACTIVITY RECORDS")
D CLEAR^VALM1
;S DTIME=BNIKDTIM
K BNIKDTIM
Q
;
HDR ;EP -- header code
S VALMHDR(1)=$$REPEAT^XLFSTR("-",80)
S VALMHDR(2)="Person Performing Activity: "_$P(^VA(200,BNIPRV,0),U)
S VALMHDR(3)=$$REPEAT^XLFSTR("-",80)
I $E($G(^TMP("BNIRECS",$J,1,0)))="N" S BNIRCNT=0,VALMHDR(4)=^TMP("BNIRECS",$J,1,0) K ^TMP("BNIRECS",$J)
E S X="",$E(X,2)="#",$E(X,5)="DATE",$E(X,15)="PRV",$E(X,20)="TIME",$E(X,25)="General Health",$E(X,41)="Spec Hlth Topic",$E(X,57)="Activity",$E(X,73)="Setting",VALMHDR(4)=X
Q
;
INIT ;EP -- init variables and list array
;S VALMSG="Q - Quit ?? for more actions + next screen - prev screen"
S VALMSG=" ?? for more actions"
D GATHER ;gather up all records for display
S VALMCNT=BNIRCNT
I VALMCNT>11 S VALMSG="+ for more records, - to back up ?? for more actions"
Q
;
GATHER ;
;gather up all records
K ^TMP($J,"BNIRECS") S BNIRCNT=0
;I '$D(^BNIREC("AC",BNIPRV)) S ^TMP("BNIRECS",$J,1,0)="No CPHAD activity records on file for this provider" Q
S (BNIRCNT,BNIIDAT,C)=0 F S BNIIDAT=$O(^BNIREC("AE",BNIIDAT)) Q:BNIIDAT="" D
.S BNIV=0 F S BNIV=$O(^BNIREC("AE",BNIIDAT,BNIV)) Q:BNIV'=+BNIV D
..Q:'$$ALLOW(BNIV)
..S BNIRCNT=BNIRCNT+1,BNIRS=BNIRCNT,^TMP("BNIRECS",$J,"IDX",BNIRCNT,BNIRCNT)=BNIV
..S BNIREC=^BNIREC(BNIV,0) D REC
..S ^TMP("BNIRECS",$J,BNIRCNT,0)=BNIX
K BNIX,BNIV,BNIREC
Q
;
REC ;
S BNIX=$J(BNIRS,3)
S $E(BNIX,5)=$$DATE($P(BNIREC,U))
S X=$P(BNIREC,U,8) I X S X=$P($G(^VA(200,X,0)),U,2) I X="" S X="???"
S $E(BNIX,15)=X
S $E(BNIX,20)=$P(BNIREC,U,9)
S $E(BNIX,25)=$E($$VAL^XBDIQ1(90510,BNIV,.11),1,15)
S $E(BNIX,41)=$E($$VAL^XBDIQ1(90510,BNIV,.12),1,15)
S $E(BNIX,57)=$E($$VAL^XBDIQ1(90510,BNIV,.13),1,15)
S $E(BNIX,73)=$E($$VAL^XBDIQ1(90510,BNIV,.15),1,10)
Q
DATE(D) ;
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
HELP ;EP -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K BNIRCNT,^TMP("BNIRECS",$J)
K VALMCC,VALMHDR
Q
;
EXPND ; -- expand code
Q
;
TEXT ;
;;Computerized Public Health Activity Data System (CPHAD) Data Entry
;;
;;*********************************
;;* Update CPHAD Activity Records *
;;*********************************
;;
;;This option is used to update CPHAD activity records.
;;You will be asked to specify which records will be displayed
;;for editing. You will also be asked if you want to display
;;only your records or all records.
;;
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(5,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(5,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(7,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(7,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(9,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(9,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(11,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(11,2,1,$S('$G(X):1,$P(^BNIGS(X,0),U,3)=1:0,1:1)) ;don't allow field 8 if not other
D REFRESH^DDSUTL
Q
ASPOST ;EP - called from screenman
D REQ^DDSUTL(13,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(13,2,1,$S('$G(X):1,$P(^BNIAS(X,0),U,3)=1:0,1:1)) ;don't allow field 8 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
I '$O(^BNISITE(BNISITE,11,0)) 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
I '$D(^BNISITE(BNISITE,11,"B",I)) Q 0
Q 1
ADD ;EP - ADD a record
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 ADDX
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="^BNIREC(",DLAYGO=90510,DIADD=1,X=BNIDATE
S DIC("DR")=".02////"_DT_";.03////"_DUZ_";.06////"_DUZ(2)_";.07///"_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),"CPHAD Record is NOT complete!! Deleting Record.",! D PAUSE G ADDX
;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
ADDR1 ;
S DA=BNIR,DDSFILE=90510,DR=$S($G(BNIADDQ):"[BNIA UPDATE ACTIVITY RECORD]",1:"[BNI UPDATE ACTIVITY RECORD]") D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" D PAUSE G ADDX
;check record for completeness
D CHECKREC
I Q D G:BNIA="E" ADDR1 D DELR,PAUSE G ADDX
.S BNIA="" K DIR
.S DIR(0)="S^E:Edit and complete the Record;D:Delete the Incomplete 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
ADDX ;
D BACK
Q
CHECKREC ;
D FULL^VALM1,CLEAR^VALM1
S Q="" F F=.07,.08,.09,.11,.12,.13 I $P(^BNIREC(BNIR,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(^BNIREC(BNIR,0),U,15)="" D
.W !,"ACTIVITY SETTING is required and is missing." S Q=1
S X=$P(^BNIREC(BNIR,0),U,11) I X,$P(^BNIGHC(X,0),U,3),$P($G(^BNIREC(BNIR,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(^BNIREC(BNIR,0),U,12) I X,$P(^BNISHT(X,0),U,5),$P($G(^BNIREC(BNIR,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(^BNIREC(BNIR,0),U,13) I X,$P(^BNITOA(X,0),U,3),$P($G(^BNIREC(BNIR,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(^BNIREC(BNIR,0),U,14) I X,$P(^BNIGS(X,0),U,3),$P($G(^BNIREC(BNIR,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(^BNIREC(BNIR,0),U,15) I X,$P(^BNIAS(X,0),U,3),$P($G(^BNIREC(BNIR,0)),U,16)="" D
.W !,"ACTIVITY SETTING is ",$P(^BNIAS(X,0),U),!," and the COMMUNITY is missing." S Q=1
Q
DELR ;
W !!,"Deleting CPHAD record for ",$$VAL^XBDIQ1(90510,BNIR,.01)
S DA=BNIR,DIK="^BNIREC(" 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
BACK ;EP
D TERM^VALM0
S VALMBCK="R"
D INIT
S VALMCNT=BNIRCNT
Q
;
EDITR ;EP - called from protocol
K DIR S DIR(0)="N^1:"_BNIRCNT_":0",DIR("A")="Edit Which Record" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !,"No record selected." D PAUSE G EDITX
S BNIR1=+Y I 'BNIR1 K VALMY,XQORNOD W !,"No record selected." D PAUSE G EDITX
S BNIR=^TMP("BNIRECS",$J,"IDX",BNIR1,BNIR1) I 'BNIR K BNIRDEL,BNIR D PAUSE G EDITX
I '$D(^BNIREC(BNIR,0)) W !,"Not a valid CPHAD RECORD." K BNIRDEL,BNIR D PAUSE G EDITX
D FULL^VALM1
W:$D(IOF) @IOF W !,"You are editing the following record:",!!,VALMHDR(4),!,$$REPEAT^XLFSTR("-",80),! W ^TMP("BNIRECS",$J,BNIR1,0),!!!
D FULL^VALM1
EDIT ;EP
S DIADD=1,DIE="^BNIREC(",DA=BNIR,DR="1500///NOW",DR(2,90510.0115)=".02////^S X=DUZ" D ^DIE K DIE,DA,DR,DIADD
EDIT1 ;
S DA=BNIR,DDSFILE=90510,DR=$S($G(BNIADDQ):"[BNIA UPDATE ACTIVITY RECORD]",1:"[BNI UPDATE ACTIVITY RECORD]") D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" D PAUSE G BACK
;check record for completeness
D CHECKREC
I Q D G:BNIA="E" EDIT1 D DELR,PAUSE G EDITX
.S BNIA="" K DIR
.S DIR(0)="S^E:Edit and complete the Record;D:Delete the Incomplete Record",DIR("A")="Do you wish to",DIR("B")="E" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) S BNIA="D"
.S BNIA="E"
EDITX ;
D BACK
Q
DISPR ;EP - called from protocol to display a record
K DIR S DIR(0)="N^1:"_BNIRCNT_":0",DIR("A")="Display Which Record" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !,"No record selected." D PAUSE G DISPX
S BNIR1=+Y I 'BNIR1 K VALMY,XQORNOD W !,"No record selected." D PAUSE G DISPX
S BNIR=^TMP("BNIRECS",$J,"IDX",BNIR1,BNIR1) I 'BNIR K BNIRDEL,BNIR D PAUSE G DISPX
I '$D(^BNIREC(BNIR,0)) W !,"Not a valid CPHAD RECORD." K BNIRDEL,BNIR D PAUSE G DISPX
D FULL^VALM1
S BNIREC=BNIR D ^BNIRD
DISPX ;
D BACK
Q
DELETER ;EP - called from protocol to display a record
K DIR S DIR(0)="N^1:"_BNIRCNT_":0",DIR("A")="Delete Which Record" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !,"No record selected." D PAUSE G DELETERX
S BNIR1=+Y I 'BNIR1 K VALMY,XQORNOD W !,"No record selected." D PAUSE G DELETERX
S BNIR=^TMP("BNIRECS",$J,"IDX",BNIR1,BNIR1) I 'BNIR K BNIRDEL,BNIR D PAUSE G DELETERX
I '$D(^BNIREC(BNIR,0)) W !,"Not a valid CPHAD RECORD." K BNIRDEL,BNIR D PAUSE G DELETERX
D FULL^VALM1
;
S DA=BNIR,DIC="^BNIREC(" D EN^DIQ
W !! S DIR(0)="Y",DIR("A")="Are you sure you want to DELETE this record",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
G:$D(DIRUT) DELETERX
G:'Y DELETERX
D DELR
DELETERX ;
D BACK
Q
ATIP(X) ;EP - called from input transform on activity time field
I '$G(X) D EN^DDIOL(" * must be a value greated than 0 *") Q 0
I $P(X,".",2)="" Q 1
NEW %
S %=$P(X,".",2)
I %'="0",%'="25",%'="5",%'="75" Q 0
Q 1
ALLOW(R) ;EP
I $D(^BNISITE(BNISITE,12,"B",DUZ)) Q 1 ;allow all with access
I $P(^BNIREC(R,0),U,8)=DUZ Q 1
I $P(^BNIREC(R,0),U,3)=DUZ Q 1
Q 0
BNIE ; IHS/CMI/LAB - Data 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:11
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 WHICH
+6 IF BNIPRV=""
DO EOJ
QUIT
+7 DO ADDQ
+8 IF BNIADDQ=""
GOTO START1
+9 DO EN
DO FULL^VALM1
DO EXIT
+10 DO EOJ
+11 QUIT
+12 ;
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
WHICH ;
+1 SET BNIPRV=""
+2 DO ^XBFMK
+3 WRITE !
KILL DIC
SET DIC=200
SET DIC(0)="AEMQ"
SET DIC("A")="Enter Person who Performed the Activity: "
SET DIC("B")=$PIECE(^VA(200,DUZ,0),U)
DO ^DIC
KILL DIC
+4 IF Y=-1
QUIT
+5 SET BNIPRV=+Y
+6 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
EN ; EP -- main entry point for BNI UPDATE ACTIVITY RECORDS
+1 SET VALMCC=1
+2 DO EN^VALM("BNI UPDATE ACTIVITY RECORDS")
+3 DO CLEAR^VALM1
+4 ;S DTIME=BNIKDTIM
+5 KILL BNIKDTIM
+6 QUIT
+7 ;
HDR ;EP -- header code
+1 SET VALMHDR(1)=$$REPEAT^XLFSTR("-",80)
+2 SET VALMHDR(2)="Person Performing Activity: "_$PIECE(^VA(200,BNIPRV,0),U)
+3 SET VALMHDR(3)=$$REPEAT^XLFSTR("-",80)
+4 IF $EXTRACT($GET(^TMP("BNIRECS",$JOB,1,0)))="N"
SET BNIRCNT=0
SET VALMHDR(4)=^TMP("BNIRECS",$JOB,1,0)
KILL ^TMP("BNIRECS",$JOB)
+5 IF '$TEST
SET X=""
SET $EXTRACT(X,2)="#"
SET $EXTRACT(X,5)="DATE"
SET $EXTRACT(X,15)="PRV"
SET $EXTRACT(X,20)="TIME"
SET $EXTRACT(X,25)="General Health"
SET $EXTRACT(X,41)="Spec Hlth Topic"
SET $EXTRACT(X,57)="Activity"
SET $EXTRACT(X,73)="Setting"
SET VALMHDR(4)=X
+6 QUIT
+7 ;
INIT ;EP -- init variables and list array
+1 ;S VALMSG="Q - Quit ?? for more actions + next screen - prev screen"
+2 SET VALMSG=" ?? for more actions"
+3 ;gather up all records for display
DO GATHER
+4 SET VALMCNT=BNIRCNT
+5 IF VALMCNT>11
SET VALMSG="+ for more records, - to back up ?? for more actions"
+6 QUIT
+7 ;
GATHER ;
+1 ;gather up all records
+2 KILL ^TMP($JOB,"BNIRECS")
SET BNIRCNT=0
+3 ;I '$D(^BNIREC("AC",BNIPRV)) S ^TMP("BNIRECS",$J,1,0)="No CPHAD activity records on file for this provider" Q
+4 SET (BNIRCNT,BNIIDAT,C)=0
FOR
SET BNIIDAT=$ORDER(^BNIREC("AE",BNIIDAT))
IF BNIIDAT=""
QUIT
Begin DoDot:1
+5 SET BNIV=0
FOR
SET BNIV=$ORDER(^BNIREC("AE",BNIIDAT,BNIV))
IF BNIV'=+BNIV
QUIT
Begin DoDot:2
+6 IF '$$ALLOW(BNIV)
QUIT
+7 SET BNIRCNT=BNIRCNT+1
SET BNIRS=BNIRCNT
SET ^TMP("BNIRECS",$JOB,"IDX",BNIRCNT,BNIRCNT)=BNIV
+8 SET BNIREC=^BNIREC(BNIV,0)
DO REC
+9 SET ^TMP("BNIRECS",$JOB,BNIRCNT,0)=BNIX
End DoDot:2
End DoDot:1
+10 KILL BNIX,BNIV,BNIREC
+11 QUIT
+12 ;
REC ;
+1 SET BNIX=$JUSTIFY(BNIRS,3)
+2 SET $EXTRACT(BNIX,5)=$$DATE($PIECE(BNIREC,U))
+3 SET X=$PIECE(BNIREC,U,8)
IF X
SET X=$PIECE($GET(^VA(200,X,0)),U,2)
IF X=""
SET X="???"
+4 SET $EXTRACT(BNIX,15)=X
+5 SET $EXTRACT(BNIX,20)=$PIECE(BNIREC,U,9)
+6 SET $EXTRACT(BNIX,25)=$EXTRACT($$VAL^XBDIQ1(90510,BNIV,.11),1,15)
+7 SET $EXTRACT(BNIX,41)=$EXTRACT($$VAL^XBDIQ1(90510,BNIV,.12),1,15)
+8 SET $EXTRACT(BNIX,57)=$EXTRACT($$VAL^XBDIQ1(90510,BNIV,.13),1,15)
+9 SET $EXTRACT(BNIX,73)=$EXTRACT($$VAL^XBDIQ1(90510,BNIV,.15),1,10)
+10 QUIT
DATE(D) ;
+1 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+2 ;
HELP ;EP -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL BNIRCNT,^TMP("BNIRECS",$JOB)
+2 KILL VALMCC,VALMHDR
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
TEXT ;
+1 ;;Computerized Public Health Activity Data System (CPHAD) Data Entry
+2 ;;
+3 ;;*********************************
+4 ;;* Update CPHAD Activity Records *
+5 ;;*********************************
+6 ;;
+7 ;;This option is used to update CPHAD activity records.
+8 ;;You will be asked to specify which records will be displayed
+9 ;;for editing. You will also be asked if you want to display
+10 ;;only your records or all records.
+11 ;;
+12 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(5,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(5,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(7,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(7,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(9,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(9,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(11,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 8 if not other
DO UNED^DDSUTL(11,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(13,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 8 if not other
DO UNED^DDSUTL(13,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 ;S Z=$P($G(^BNISITE(BNISITE,0)),U,3)
+4 ;I 'Z Q 1
+5 IF '$ORDER(^BNISITE(BNISITE,11,0))
QUIT 1
+6 ;S C=$P(^AUTTCOM(Y,0),U)
+7 ;I '$D(^ATXAX(Z,0)) Q 1
+8 ;I '$D(^ATXAX(Z,21,"B",C)) Q 0
+9 IF '$DATA(^BNISITE(BNISITE,11,"B",I))
QUIT 0
+10 QUIT 1
ADD ;EP - ADD a record
+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 ADDX
+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="^BNIREC("
SET DLAYGO=90510
SET DIADD=1
SET X=BNIDATE
+2 SET DIC("DR")=".02////"_DT_";.03////"_DUZ_";.06////"_DUZ(2)_";.07///"_DUZ(2)_";.08////"_BNIPRV
+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 Record is NOT complete!! Deleting Record.",!
DO PAUSE
GOTO ADDX
+5 ;update multiple of user last update/date edited
+6 SET BNIR=+Y
+7 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
ADDR1 ;
+1 SET DA=BNIR
SET DDSFILE=90510
SET DR=$SELECT($GET(BNIADDQ):"[BNIA UPDATE ACTIVITY RECORD]",1:"[BNI UPDATE ACTIVITY RECORD]")
DO ^DDS
+2 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
DO PAUSE
GOTO ADDX
+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 Record;D:Delete the Incomplete 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
GOTO ADDX
ADDX ;
+1 DO BACK
+2 QUIT
CHECKREC ;
+1 DO FULL^VALM1
DO CLEAR^VALM1
+2 SET Q=""
FOR F=.07,.08,.09,.11,.12,.13
IF $PIECE(^BNIREC(BNIR,0),U,+$PIECE(F,".",2))=""
Begin DoDot:1
+3 WRITE !,$PIECE(^DD(90510,F,0),U)," is a required field and is missing."
SET Q=1
End DoDot:1
+4 IF $PIECE($GET(^BNISITE(BNISITE,0)),U,2)
IF $PIECE(^BNIREC(BNIR,0),U,15)=""
Begin DoDot:1
+5 WRITE !,"ACTIVITY SETTING is required and is missing."
SET Q=1
End DoDot:1
+6 SET X=$PIECE(^BNIREC(BNIR,0),U,11)
IF X
IF $PIECE(^BNIGHC(X,0),U,3)
IF $PIECE($GET(^BNIREC(BNIR,11)),U,1)=""
Begin DoDot:1
+7 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
+8 SET X=$PIECE(^BNIREC(BNIR,0),U,12)
IF X
IF $PIECE(^BNISHT(X,0),U,5)
IF $PIECE($GET(^BNIREC(BNIR,11)),U,2)=""
Begin DoDot:1
+9 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
+10 SET X=$PIECE(^BNIREC(BNIR,0),U,13)
IF X
IF $PIECE(^BNITOA(X,0),U,3)
IF $PIECE($GET(^BNIREC(BNIR,11)),U,3)=""
Begin DoDot:1
+11 WRITE !,"TYPE OF ACTIVITY is ",$PIECE(^BNITOA(X,0),U),!," and the text of TYPE OF ACTIVITY (OTHER) is missing."
SET Q=1
End DoDot:1
+12 SET X=$PIECE(^BNIREC(BNIR,0),U,14)
IF X
IF $PIECE(^BNIGS(X,0),U,3)
IF $PIECE($GET(^BNIREC(BNIR,12)),U,1)=""
Begin DoDot:1
+13 WRITE !,"GROUP SERVED is ",$PIECE(^BNIGS(X,0),U),!," and the text of GROUP SERVED (OTHER) is missing."
SET Q=1
End DoDot:1
+14 SET X=$PIECE(^BNIREC(BNIR,0),U,15)
IF X
IF $PIECE(^BNIAS(X,0),U,3)
IF $PIECE($GET(^BNIREC(BNIR,0)),U,16)=""
Begin DoDot:1
+15 WRITE !,"ACTIVITY SETTING is ",$PIECE(^BNIAS(X,0),U),!," and the COMMUNITY is missing."
SET Q=1
End DoDot:1
+16 QUIT
DELR ;
+1 WRITE !!,"Deleting CPHAD record for ",$$VAL^XBDIQ1(90510,BNIR,.01)
+2 SET DA=BNIR
SET DIK="^BNIREC("
DO ^DIK
KILL DIK,DA
+3 QUIT
PAUSE ;EP
+1 SET DIR(0)="EO"
SET DIR("A")="Press enter to continue...."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 QUIT
BACK ;EP
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO INIT
+4 SET VALMCNT=BNIRCNT
+5 QUIT
+6 ;
EDITR ;EP - called from protocol
+1 KILL DIR
SET DIR(0)="N^1:"_BNIRCNT_":0"
SET DIR("A")="Edit Which Record"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
WRITE !,"No record selected."
DO PAUSE
GOTO EDITX
+3 SET BNIR1=+Y
IF 'BNIR1
KILL VALMY,XQORNOD
WRITE !,"No record selected."
DO PAUSE
GOTO EDITX
+4 SET BNIR=^TMP("BNIRECS",$JOB,"IDX",BNIR1,BNIR1)
IF 'BNIR
KILL BNIRDEL,BNIR
DO PAUSE
GOTO EDITX
+5 IF '$DATA(^BNIREC(BNIR,0))
WRITE !,"Not a valid CPHAD RECORD."
KILL BNIRDEL,BNIR
DO PAUSE
GOTO EDITX
+6 DO FULL^VALM1
+7 IF $DATA(IOF)
WRITE @IOF
WRITE !,"You are editing the following record:",!!,VALMHDR(4),!,$$REPEAT^XLFSTR("-",80),!
WRITE ^TMP("BNIRECS",$JOB,BNIR1,0),!!!
+8 DO FULL^VALM1
EDIT ;EP
+1 SET DIADD=1
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,DIADD
EDIT1 ;
+1 SET DA=BNIR
SET DDSFILE=90510
SET DR=$SELECT($GET(BNIADDQ):"[BNIA UPDATE ACTIVITY RECORD]",1:"[BNI UPDATE ACTIVITY RECORD]")
DO ^DDS
+2 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
DO PAUSE
GOTO BACK
+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 Record;D:Delete the Incomplete 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="E"
End DoDot:1
IF BNIA="E"
GOTO EDIT1
DO DELR
DO PAUSE
GOTO EDITX
EDITX ;
+1 DO BACK
+2 QUIT
DISPR ;EP - called from protocol to display a record
+1 KILL DIR
SET DIR(0)="N^1:"_BNIRCNT_":0"
SET DIR("A")="Display Which Record"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
WRITE !,"No record selected."
DO PAUSE
GOTO DISPX
+3 SET BNIR1=+Y
IF 'BNIR1
KILL VALMY,XQORNOD
WRITE !,"No record selected."
DO PAUSE
GOTO DISPX
+4 SET BNIR=^TMP("BNIRECS",$JOB,"IDX",BNIR1,BNIR1)
IF 'BNIR
KILL BNIRDEL,BNIR
DO PAUSE
GOTO DISPX
+5 IF '$DATA(^BNIREC(BNIR,0))
WRITE !,"Not a valid CPHAD RECORD."
KILL BNIRDEL,BNIR
DO PAUSE
GOTO DISPX
+6 DO FULL^VALM1
+7 SET BNIREC=BNIR
DO ^BNIRD
DISPX ;
+1 DO BACK
+2 QUIT
DELETER ;EP - called from protocol to display a record
+1 KILL DIR
SET DIR(0)="N^1:"_BNIRCNT_":0"
SET DIR("A")="Delete Which Record"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
WRITE !,"No record selected."
DO PAUSE
GOTO DELETERX
+3 SET BNIR1=+Y
IF 'BNIR1
KILL VALMY,XQORNOD
WRITE !,"No record selected."
DO PAUSE
GOTO DELETERX
+4 SET BNIR=^TMP("BNIRECS",$JOB,"IDX",BNIR1,BNIR1)
IF 'BNIR
KILL BNIRDEL,BNIR
DO PAUSE
GOTO DELETERX
+5 IF '$DATA(^BNIREC(BNIR,0))
WRITE !,"Not a valid CPHAD RECORD."
KILL BNIRDEL,BNIR
DO PAUSE
GOTO DELETERX
+6 DO FULL^VALM1
+7 ;
+8 SET DA=BNIR
SET DIC="^BNIREC("
DO EN^DIQ
+9 WRITE !!
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to DELETE this record"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+10 IF $DATA(DIRUT)
GOTO DELETERX
+11 IF 'Y
GOTO DELETERX
+12 DO DELR
DELETERX ;
+1 DO BACK
+2 QUIT
ATIP(X) ;EP - called from input transform on activity time field
+1 IF '$GET(X)
DO EN^DDIOL(" * must be a value greated than 0 *")
QUIT 0
+2 IF $PIECE(X,".",2)=""
QUIT 1
+3 NEW %
+4 SET %=$PIECE(X,".",2)
+5 IF %'="0"
IF %'="25"
IF %'="5"
IF %'="75"
QUIT 0
+6 QUIT 1
ALLOW(R) ;EP
+1 ;allow all with access
IF $DATA(^BNISITE(BNISITE,12,"B",DUZ))
QUIT 1
+2 IF $PIECE(^BNIREC(R,0),U,8)=DUZ
QUIT 1
+3 IF $PIECE(^BNIREC(R,0),U,3)=DUZ
QUIT 1
+4 QUIT 0
