BCHUAR.m

BCHUAR ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 16-AUG-1994 12 Apr 2006 10:24 AM ; 

 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 ;; ;

START ; Write Header

 D EN^BCHUEKL ; -- kill all vars before starting

 D EN^XBVK("BCH") ;IHS/CMI/TMJ PATCH #16 Variable Kill

START1 W:$D(IOF) @IOF

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

 K X,J

 W !!

 D ^BCHUIN ;Initialize vars, etc.

 ;loop through until user wants to quit

 S BCHPROV="" D GETPROV I BCHPROV  S BCHPROG="" D GETPROG I BCHPROG]""  S BCHDATE="" D GETDATE I BCHDATE  D EN,FULL^VALM1,EXIT

 D EOJ

 Q

 ;

RNS ;EP

 D EN^BCHUEKL

 D EN^XBVK("BCH")

 S BCHRNS=1

 G START1

UP1 ;

 D EN^BCHUEKL

 D EN^XBVK("BCH")

 S BCHF2=1

 G START1

ABB ;EP

 D EN^XBVK("BCH")

 D EN^BCHUEKL

 S BCHUABFO=1

 G START1

EOJ ;EOJ CLEANUP

 D ^BCHUEKL

 K BCHRNS

 Q

GETDATE ;EP  GET DATE OF ENCOUNTER

 G TEST

 S BCHDATE="",DIR(0)="DO^:"_DT_":EPT",DIR("A")="Enter DATE OF SERVICE" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q:$D(DIRUT)

 S %DT="ET" D ^%DT G:Y<0 GETDATE

 I Y>DT W "  <Future dates not allowed>",$C(7),$C(7) K X G GETDATE

 S BCHDATE=Y

 D DD^%DT

 ;

TEST ;EP

 S BCHDATE="",DIR(0)="90002,.01O",DIR("A")="Enter DATE OF SERVICE" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q:$D(DIRUT)

 S %DT="ET" D ^%DT G:Y<0 GETDATE

 I Y>DT W "  <Future dates not allowed>",$C(7),$C(7) K X G GETDATE

 S BCHDATE=Y

 D DD^%DT

 Q

GETPROV ;EP - GET PROVIDER

 S BCHPROV="",DIR(0)="90002,.03O",DIR("A")="Enter Provider (CHR)" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q:$D(DIRUT)

 Q:Y=""

 S BCHPROV=+Y

 Q

 ;

GETPROG ;

 S BCHPROG=""

 K DIR,X,Y,DA S DIR(0)="90002,.02O",DIR("A")="Enter CHR PROGRAM" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q:$D(DIRUT)

 S BCHPROG=Y,BCHPROG(0)=$P(Y(0),U)

 Q

EN ; EP -- main entry point for BCH UPDATE ACTIVITY RECORDS

 D TERM^VALM0

 S VALMCC=1

 D EN^VALM("BCH UPDATE ACTIVITY RECORDS")

 D CLEAR^VALM1

 Q

 ;

HDR ; EP -- header code

 S VALMHDR(1)=BCHDASH

 S VALMHDR(2)="Date of Encounter:  "_$$FTIME^VALM1(BCHDATE)_"      Program:  "_BCHPROG(0)

 S VALMHDR(3)="Provider (CHR): "_$P(^VA(200,BCHPROV,0),U)

 S VALMHDR(4)=BCHDASH

 I $E($G(BCHVRECS(1,0)))="N" S BCHRCNT=0,VALMHDR(5)=BCHVRECS(1,0) K BCHVRECS

 E  S VALMHDR(5)="  #  PATIENT NAME      HRN/CHR ID        ASSESSMENT                LOC  TRAVEL"

 Q

 ;

INIT ; -- init variables and list array

 D GATHER^BCHUARL ;gather up all records for display

 S VALMCNT=BCHRCNT

 Q

 ;

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

 Q

 ;

EXIT ; -- exit code

 K BCHRCNT,BCHVRECS

 K VALMCC,VALMHDR,VALMBCK,VALMCNT

 Q

 ;

EXPND ; -- expand code

 Q

 ;

TEXT ;

 ;;CHR Data Entry Module

 ;;

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

 ;;* Update CHR Records *

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

 ;;

 Q

BCHUAR    ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 16-AUG-1994 12 Apr 2006 10:24 AM ; 

 +1       ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 +2       ;; ;

START     ; Write Header

 +1       ; -- kill all vars before starting

           DO EN^BCHUEKL

 +2       ;IHS/CMI/TMJ PATCH #16 Variable Kill

           DO EN^XBVK("BCH")

START1     IF $DATA(IOF)

               WRITE @IOF

 +1        FOR J=1:1:5

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

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

 +2        KILL X,J

 +3        WRITE !!

 +4       ;Initialize vars, etc.

           DO ^BCHUIN

 +5       ;loop through until user wants to quit

 +6        SET BCHPROV=""

           DO GETPROV

           IF BCHPROV

               SET BCHPROG=""

               DO GETPROG

               IF BCHPROG]""

                   SET BCHDATE=""

                   DO GETDATE

                   IF BCHDATE

                       DO EN

                       DO FULL^VALM1

                       DO EXIT

 +7        DO EOJ

 +8        QUIT 

 +9       ;

RNS       ;EP

 +1        DO EN^BCHUEKL

 +2        DO EN^XBVK("BCH")

 +3        SET BCHRNS=1

 +4        GOTO START1

UP1       ;

 +1        DO EN^BCHUEKL

 +2        DO EN^XBVK("BCH")

 +3        SET BCHF2=1

 +4        GOTO START1

ABB       ;EP

 +1        DO EN^XBVK("BCH")

 +2        DO EN^BCHUEKL

 +3        SET BCHUABFO=1

 +4        GOTO START1

EOJ       ;EOJ CLEANUP

 +1        DO ^BCHUEKL

 +2        KILL BCHRNS

 +3        QUIT 

GETDATE   ;EP  GET DATE OF ENCOUNTER

 +1        GOTO TEST

 +2        SET BCHDATE=""

           SET DIR(0)="DO^:"_DT_":EPT"

           SET DIR("A")="Enter DATE OF SERVICE"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               QUIT 

 +4        SET %DT="ET"

           DO ^%DT

           IF Y<0

               GOTO GETDATE

 +5        IF Y>DT

               WRITE "  <Future dates not allowed>",$CHAR(7),$CHAR(7)

               KILL X

               GOTO GETDATE

 +6        SET BCHDATE=Y

 +7        DO DD^%DT

 +8       ;

TEST      ;EP

 +1        SET BCHDATE=""

           SET DIR(0)="90002,.01O"

           SET DIR("A")="Enter DATE OF SERVICE"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               QUIT 

 +3        SET %DT="ET"

           DO ^%DT

           IF Y<0

               GOTO GETDATE

 +4        IF Y>DT

               WRITE "  <Future dates not allowed>",$CHAR(7),$CHAR(7)

               KILL X

               GOTO GETDATE

 +5        SET BCHDATE=Y

 +6        DO DD^%DT

 +7        QUIT 

GETPROV   ;EP - GET PROVIDER

 +1        SET BCHPROV=""

           SET DIR(0)="90002,.03O"

           SET DIR("A")="Enter Provider (CHR)"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               QUIT 

 +3        IF Y=""

               QUIT 

 +4        SET BCHPROV=+Y

 +5        QUIT 

 +6       ;

GETPROG   ;

 +1        SET BCHPROG=""

 +2        KILL DIR,X,Y,DA

           SET DIR(0)="90002,.02O"

           SET DIR("A")="Enter CHR PROGRAM"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               QUIT 

 +4        SET BCHPROG=Y

           SET BCHPROG(0)=$PIECE(Y(0),U)

 +5        QUIT 

EN        ; EP -- main entry point for BCH UPDATE ACTIVITY RECORDS

 +1        DO TERM^VALM0

 +2        SET VALMCC=1

 +3        DO EN^VALM("BCH UPDATE ACTIVITY RECORDS")

 +4        DO CLEAR^VALM1

 +5        QUIT 

 +6       ;

HDR       ; EP -- header code

 +1        SET VALMHDR(1)=BCHDASH

 +2        SET VALMHDR(2)="Date of Encounter:  "_$$FTIME^VALM1(BCHDATE)_"      Program:  "_BCHPROG(0)

 +3        SET VALMHDR(3)="Provider (CHR): "_$PIECE(^VA(200,BCHPROV,0),U)

 +4        SET VALMHDR(4)=BCHDASH

 +5        IF $EXTRACT($GET(BCHVRECS(1,0)))="N"

               SET BCHRCNT=0

               SET VALMHDR(5)=BCHVRECS(1,0)

               KILL BCHVRECS

 +6       IF '$TEST

               SET VALMHDR(5)="  #  PATIENT NAME      HRN/CHR ID        ASSESSMENT                LOC  TRAVEL"

 +7        QUIT 

 +8       ;

INIT      ; -- init variables and list array

 +1       ;gather up all records for display

           DO GATHER^BCHUARL

 +2        SET VALMCNT=BCHRCNT

 +3        QUIT 

 +4       ;

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT 

 +3       ;

EXIT      ; -- exit code

 +1        KILL BCHRCNT,BCHVRECS

 +2        KILL VALMCC,VALMHDR,VALMBCK,VALMCNT

 +3        QUIT 

 +4       ;

EXPND     ; -- expand code

 +1        QUIT 

 +2       ;

TEXT      ;

 +1       ;;CHR Data Entry Module

 +2       ;;

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

 +4       ;;* Update CHR Records *

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

 +6       ;;

 +7        QUIT