Routine: BCHUFP

BCHUFP ; IHS/CMI/LAB - PRINT ENCOUNTER RECORD ;

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

 ;IHS/TUCSON/LAB - patch 2 - 06/03/97 - added a few variables to kill in XIT+1

 ;print individual forms for each member of group

START ;

 I '$D(IOF) D HOME^%ZIS

 W @(IOF),!!

 W "**********  ENCOUNTER FORM PRINT  **********",!!

 W "This report will produce hard copy computed generated encounter forms.",!

GETDATES ;

BD ;get beginning date

 W !,"Please enter the date range for which forms should be printed.",!

 W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Date" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G XIT

 S BCHBD=Y

ED ;get ending date

 W ! S DIR(0)="D^"_BCHBD_":DT:EP",DIR("A")="Enter ending Date" S Y=BCHBD D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G BD

 S BCHED=Y

 S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y

PAT ;one or all patients

 G PROV

 S BCHPAT=""

 S DIR(0)="Y",DIR("A")="Do you wish to print forms for one particular PATIENT",DIR("B")="Y" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 G:$D(DIRUT) GETDATES

 G:'Y PROV

 I Y=1 S DIC("A")="Enter PATIENT Name: ",DIC=9000001,DIC(0)="AEQMZ" D ^DIC G PAT:Y<0 S BCHPAT=+Y

PROV ;limit by provider

 S BCHPROV=""

 S DIR(0)="Y",DIR("A")="Do you wish to print forms for one particular CHR",DIR("B")="Y" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 G:$D(DIRUT) GETDATES

 G:'Y ZIS

 I Y=1 S DIC("A")="Enter CHR Name: ",DIC=200,DIC(0)="AEQMZ" D ^DIC G PROV:Y<0 S BCHPROV=+Y

ZIS ;

 S XBRC="COMP^BCHUFP",XBRP="PRINT^BCHUFP",XBNS="BCH",XBRX="XIT^BCHUFP"

 D ^XBDBQUE

XIT ;

 K BCHR11,BCHR12,BCHRC,BCHRX,BCHRCNT,BCHRNODE,BCHRRPNM,BCHPREC,BCHR13,BCHW,BCHWP,BCHIOM,BCHX1 ;IHS/TUCSON/LAB - patch 2

 K ZTSK,Y,BCHBD,BCHED,IO("Q"),BCH80D,BCHBTH,BCHHRCN,BCHJOB,BCHLENG,BCHPCNT,BCHPG,BCHPROV,BCHX,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,XBNS,XBRC,XBRP,XBTX,D,BCHC,DIW,DIWI,DIWT,DIWTC,DIWX,DN

 K BCHPRNM,BCHPRNT,BCHPROB,BCHPRV,BCHR,BCHRCNT,BCHRLOC,BCHSD,BCHTOT,BCHBDD,BCHBT,BCHEDD,BCHEDO,BCHBDO,BCHBT,BCHFOUND,BCHHIT,BCHID,BCHLINE,BCHP,BCHHRN,BCHODAT,BCHQUIT,BCHR0,BCHTICL,BCHTNRQ,BCHTQ,BCHTTXT

COMP ;EP - do nothing

PRINT ; EP - print individual forms

 S BCHQUIT=0

D ; Run by visit date

 S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X

 S BCHODAT=BCHSD_".9999" F  S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED)!(BCHQUIT)  D V1

V1 ;

 S (BCHR,BCHRCNT)=0 F  S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR!(BCHQUIT)  I $D(^BCHR(BCHR,0)) D  I F D PRINT1^BCHUFPP

 .;CHECK PROVIDER

 .S F=0

 .I 'BCHPROV S F=1 Q

 .I BCHPROV=$P(^BCHR(BCHR,0),U,3) S F=1

DEMO ;EP

 I $P(^BCHR(BCHR,0),U,4)="",$P($G(^BCHR(BCHR,11)),U,12)="" D  Q

 .I $Y>(IOSL-4) D FF^BCHUFPP Q:BCHQUIT

 .W !!,"<No Demographic Information...Non-Patient Encounter>",!

 .W !,$TR($J("",80)," ","*")

 .D FF^BCHUFPP

.Q

 I $Y>(IOSL-9) D FF^BCHUFPP Q:BCHQUIT

 S BCHR11=$G(^BCHR(BCHR,11))

 S DFN=$P(BCHR0,U,4)

 S BCHHRN=$S(DFN]"":$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),1:$P(BCHR11,U,11))

 S:BCHHRN="" BCHHRN="<?????>"

 I DFN W !!?3,"HR#:  ",BCHHRN

 I 'DFN,$P($G(^BCHR(BCHR,11)),U,12) W !!?3,"CHR NON REG ID: ",$P(^BCHR(BCHR,11),U,13)

 W ?35,"SEX: ",$S(DFN]"":$$EXTSET^XBFUNC(2,.02,$P(^DPT(DFN,0),U,2)),1:$P(BCHR11,U,3))

 W !?3,"NAME:  ",$S(DFN]"":$P(^DPT(DFN,0),U),1:$P(BCHR11,U))

 W ?35,"Tribe:  " I DFN]"",$P($G(^AUPNPAT(DFN,11)),U,8) W $P(^AUTTTRI($P(^AUPNPAT(DFN,11),U,8),0),U)

 E  I $P(BCHR11,U,5) W $P(^AUTTTRI($P(BCHR11,U,5),0),U)

 W !?3,"SSN:  ",$S(DFN]"":"XXX-XX-"_$E($P(^DPT(DFN,0),U,9),6,9),1:$P(BCHR11,U,4))

 W ?35,"RESIDENCE:  " I DFN]"" W $P($G(^AUPNPAT(DFN,11)),U,18)

 E  W $P(BCHR11,U,7)

 W !?3,"DOB:  "  I DFN]"" S Y=$P(^DPT(DFN,0),U,3) I Y]"" D DD^%DT W Y

 I '$G(DFN) S Y=$P(BCHR11,U,2) I Y]"" D DD^%DT W Y

 W ?35,"FACILITY: " I $P(BCHR11,U,9)]"" W $P(^DIC(4,$P(BCHR11,U,9),0),U)

 ;W !?3,"PURPOSE OF REFERRAL:  ",$P($G(^BCHR(BCHR,21)),U)

 ;W !?3,"INSURER:  ",$P($G(^BCHR(BCHR,41)),U)

 W !!?35,"CHR SIGNATURE: _____________________________",!

 W !,$TR($J("",80)," ","*")

 D FF^BCHUFPP

BCHUFP    ; IHS/CMI/LAB - PRINT ENCOUNTER RECORD ;

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

 +2       ;

 +3       ;IHS/TUCSON/LAB - patch 2 - 06/03/97 - added a few variables to kill in XIT+1

 +4       ;

 +5       ;print individual forms for each member of group

START     ;

 +1        IF '$DATA(IOF)

               DO HOME^%ZIS

 +2        WRITE @(IOF),!!

 +3        WRITE "**********  ENCOUNTER FORM PRINT  **********",!!

 +4        WRITE "This report will produce hard copy computed generated encounter forms.",!

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !,"Please enter the date range for which forms should be printed.",!

 +2        WRITE !

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

           SET DIR("A")="Enter beginning Date"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               GOTO XIT

 +4        SET BCHBD=Y

ED        ;get ending date

 +1        WRITE !

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

           SET DIR("A")="Enter ending Date"

           SET Y=BCHBD

           DO DD^%DT

           SET DIR("B")=Y

           SET Y=""

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO BD

 +3        SET BCHED=Y

 +4        SET X1=BCHBD

           SET X2=-1

           DO C^%DTC

           SET BCHSD=X

           SET Y=BCHBD

           DO DD^%DT

           SET BCHBDD=Y

           SET Y=BCHED

           DO DD^%DT

           SET BCHEDD=Y

 +5       ;

PAT       ;one or all patients

 +1        GOTO PROV

 +2        SET BCHPAT=""

 +3        SET DIR(0)="Y"

           SET DIR("A")="Do you wish to print forms for one particular PATIENT"

           SET DIR("B")="Y"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF $DATA(DIRUT)

               GOTO GETDATES

 +5        IF 'Y

               GOTO PROV

 +6        IF Y=1

               SET DIC("A")="Enter PATIENT Name: "

               SET DIC=9000001

               SET DIC(0)="AEQMZ"

               DO ^DIC

               IF Y<0

                   GOTO PAT

               SET BCHPAT=+Y

PROV      ;limit by provider

 +1        SET BCHPROV=""

 +2        SET DIR(0)="Y"

           SET DIR("A")="Do you wish to print forms for one particular CHR"

           SET DIR("B")="Y"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               GOTO GETDATES

 +4        IF 'Y

               GOTO ZIS

 +5        IF Y=1

               SET DIC("A")="Enter CHR Name: "

               SET DIC=200

               SET DIC(0)="AEQMZ"

               DO ^DIC

               IF Y<0

                   GOTO PROV

               SET BCHPROV=+Y

ZIS       ;

 +1        SET XBRC="COMP^BCHUFP"

           SET XBRP="PRINT^BCHUFP"

           SET XBNS="BCH"

           SET XBRX="XIT^BCHUFP"

 +2        DO ^XBDBQUE

 +3       ;

XIT       ;

 +1       ;IHS/TUCSON/LAB - patch 2

           KILL BCHR11,BCHR12,BCHRC,BCHRX,BCHRCNT,BCHRNODE,BCHRRPNM,BCHPREC,BCHR13,BCHW,BCHWP,BCHIOM,BCHX1

 +2        KILL ZTSK,Y,BCHBD,BCHED,IO("Q"),BCH80D,BCHBTH,BCHHRCN,BCHJOB,BCHLENG,BCHPCNT,BCHPG,BCHPROV,BCHX,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,XBNS,XBRC,XBRP,XBTX,D,BCHC,DIW,DIWI,DIWT,DIWTC,DIWX,DN

 +3        KILL BCHPRNM,BCHPRNT,BCHPROB,BCHPRV,BCHR,BCHRCNT,BCHRLOC,BCHSD,BCHTOT,BCHBDD,BCHBT,BCHEDD,BCHEDO,BCHBDO,BCHBT,BCHFOUND,BCHHIT,BCHID,BCHLINE,BCHP,BCHHRN,BCHODAT,BCHQUIT,BCHR0,BCHTICL,BCHTNRQ,BCHTQ,BCHTTXT

 +4        QUIT

COMP      ;EP - do nothing

 +1        QUIT

PRINT     ; EP - print individual forms

 +1        SET BCHQUIT=0

D         ; Run by visit date

 +1        SET X1=BCHBD

           SET X2=-1

           DO C^%DTC

           SET BCHSD=X

 +2        SET BCHODAT=BCHSD_".9999"

FOR

               SET BCHODAT=$ORDER(^BCHR("B",BCHODAT))

               IF BCHODAT=""!((BCHODAT\1)>BCHED)!(BCHQUIT)

                   QUIT

               DO V1

 +3        QUIT

V1        ;

 +1        SET (BCHR,BCHRCNT)=0

FOR

               SET BCHR=$ORDER(^BCHR("B",BCHODAT,BCHR))

               IF BCHR'=+BCHR!(BCHQUIT)

                   QUIT

               IF $DATA(^BCHR(BCHR,0))

                   Begin DoDot:1

 +2       ;CHECK PROVIDER

 +3                    SET F=0

 +4                    IF 'BCHPROV

                           SET F=1

                           QUIT

 +5                    IF BCHPROV=$PIECE(^BCHR(BCHR,0),U,3)

                           SET F=1

                   End DoDot:1

                   IF F

                       DO PRINT1^BCHUFPP

 +6        QUIT

DEMO      ;EP

 +1        IF $PIECE(^BCHR(BCHR,0),U,4)=""

               IF $PIECE($GET(^BCHR(BCHR,11)),U,12)=""

                   Begin DoDot:1

 +2                    IF $Y>(IOSL-4)

                           DO FF^BCHUFPP

                           IF BCHQUIT

                               QUIT

 +3                    WRITE !!,"<No Demographic Information...Non-Patient Encounter>",!

 +4                    WRITE !,$TRANSLATE($JUSTIFY("",80)," ","*")

 +5                    DO FF^BCHUFPP

 +6                    QUIT

                   End DoDot:1

                   QUIT

 +7        IF $Y>(IOSL-9)

               DO FF^BCHUFPP

               IF BCHQUIT

                   QUIT

 +8        SET BCHR11=$GET(^BCHR(BCHR,11))

 +9        SET DFN=$PIECE(BCHR0,U,4)

 +10       SET BCHHRN=$SELECT(DFN]"":$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),1:$PIECE(BCHR11,U,11))

 +11       IF BCHHRN=""

               SET BCHHRN="<?????>"

 +12       IF DFN

               WRITE !!?3,"HR#:  ",BCHHRN

 +13       IF 'DFN

               IF $PIECE($GET(^BCHR(BCHR,11)),U,12)

                   WRITE !!?3,"CHR NON REG ID: ",$PIECE(^BCHR(BCHR,11),U,13)

 +14       WRITE ?35,"SEX: ",$SELECT(DFN]"":$$EXTSET^XBFUNC(2,.02,$PIECE(^DPT(DFN,0),U,2)),1:$PIECE(BCHR11,U,3))

 +15       WRITE !?3,"NAME:  ",$SELECT(DFN]"":$PIECE(^DPT(DFN,0),U),1:$PIECE(BCHR11,U))

 +16       WRITE ?35,"Tribe:  "

           IF DFN]""

               IF $PIECE($GET(^AUPNPAT(DFN,11)),U,8)

                   WRITE $PIECE(^AUTTTRI($PIECE(^AUPNPAT(DFN,11),U,8),0),U)

 +17      IF '$TEST

               IF $PIECE(BCHR11,U,5)

                   WRITE $PIECE(^AUTTTRI($PIECE(BCHR11,U,5),0),U)

 +18       WRITE !?3,"SSN:  ",$SELECT(DFN]"":"XXX-XX-"_$EXTRACT($PIECE(^DPT(DFN,0),U,9),6,9),1:$PIECE(BCHR11,U,4))

 +19       WRITE ?35,"RESIDENCE:  "

           IF DFN]""

               WRITE $PIECE($GET(^AUPNPAT(DFN,11)),U,18)

 +20      IF '$TEST

               WRITE $PIECE(BCHR11,U,7)

 +21       WRITE !?3,"DOB:  "

           IF DFN]""

               SET Y=$PIECE(^DPT(DFN,0),U,3)

               IF Y]""

                   DO DD^%DT

                   WRITE Y

 +22       IF '$GET(DFN)

               SET Y=$PIECE(BCHR11,U,2)

               IF Y]""

                   DO DD^%DT

                   WRITE Y

 +23       WRITE ?35,"FACILITY: "

           IF $PIECE(BCHR11,U,9)]""

               WRITE $PIECE(^DIC(4,$PIECE(BCHR11,U,9),0),U)

 +24      ;W !?3,"PURPOSE OF REFERRAL:  ",$P($G(^BCHR(BCHR,21)),U)

 +25      ;W !?3,"INSURER:  ",$P($G(^BCHR(BCHR,41)),U)

 +26       WRITE !!?35,"CHR SIGNATURE: _____________________________",!

 +27       WRITE !,$TRANSLATE($JUSTIFY("",80)," ","*")

 +28       DO FF^BCHUFPP

 +29       QUIT

BCHUFP.m