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
Q
COMP ;EP - do nothing
Q
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
Q
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
Q
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
Q
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
