BCHUADD1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;IHS/CMI/LAB - fixed dir call to allow 1-30 characters
;
;
GETPAT ;EP
W:$D(IOF) @IOF W !!!!!?15,"****** P A T I E N T I N F O R M A T I O N ******",!!
W !,"If this encounter involved a particular patient, please enter the patient's",!,"chart # or name now. If this is not a single patient encounter,",!,"but a group encounter or an Non-Patient encounter, simply HIT the"
W !,"ENTER key to exit back and Enter N for All Other Activities.",!
W !,"Please enter the patient information now.",!
S DFN=""
S DIR(0)="FO^1:30",DIR("A")="Enter PATIENT NAME or CHART #"
S DIR("?",1)=" To find a patient, you can enter the patient's chart number;"
S DIR("?",2)=" lastname,firstname; SSN; or DOB."
S DIR("?",3)=" "
S DIR("?",4)=" If the patient cannot be found in the Patient Registration"
S DIR("?",5)=" database and you would like to capture demographic information"
S DIR("?",6)=" for this patient into the CHR database, answer NO when asked"
S DIR("?",7)=" if you would like to try another lookup. You will then be"
S DIR("?",8)=" given the opportunity to capture the patient's demographic"
S DIR("?",9)=" data on the following screen."
S DIR("?",10)=""
S DIR("?",11)=" Registered patient demographic data can only be edited via the"
S DIR("?")=" Patient Registration system."
D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I X="" W !!,"No Patient entered. Required " G ASK
I $D(DIRUT) W !,"No patient entered!! - Required." G ASK
S (X,BCHNAME)=Y,DIC="^AUPNPAT(",DIC(0)="MQE" D ^DIC K DIC
;I X="" W !!,"No Patient entered. If this is not a patient related encounter use the ",!,"'All Other Activities option'.",! D PAUSE^BCHUTIL1 Q
I Y=-1 D NOREG Q
W !?25,"Ok" S %=1 D YN^DICN I %'=1 W !!,"Try again.",! G GETPAT
S DFN=+Y D DIRX^BCHUADD S BCHF=".04",BCHV=""
S DIE="^BCHR(",DA=BCHR,DR=".04///`"_DFN D ^DIE K DA,DIE,DR
I $D(Y) W !!,"PATIENT NOT VALID! TRY AGAIN" K Y G GETPAT
Q
;
NOREG ;
W !,"That patient cannot be found in the Registration database."
W ! S DIR(0)="Y",DIR("A")="Do you want to try to lookup the patient in registration again",DIR("B")="Y" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !,"Exiting..." S BCHQUIT=1 Q
I Y G GETPAT
W !!,"Please select a patient from the Non-Registered Patient Database",!,"or enter a new Non-Registered Patient.",!
S DIC("B")=BCHNAME S DIC="^BCHRPAT(",DIC(0)="AEMQL" D ^DIC K DIC
;SCREENMAN CALL
;S DIE="^BCHR(",DA=BCHR,DR="1101///"_BCHNAME D ^DIE K DIE,DR,DA,DIU,DIV,DIW
;S DA=BCHR,DDSFILE=90002,DR="[BCH ENTER PATIENT DATA]" D ^DDS
;K DR,DA,DDSFILE,DIC,DIE
;I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q
;Q:$G(^BCHR(BCHR,11))]""
I Y=-1 W !!,"A patient is Required" G ASK
S BCHNRPAT=+Y
I $P(Y,U,3) D I 1
.W !!,"Please review and update if necessary this non-registered patient's data:"
.S DIE="^BCHRPAT(",DR="[BCH EDIT NON REG PT]",DA=BCHNRPAT D ^DIE K DA,DIE,DR
E D
.W !!,"You now have the opportunity to update this patient's demographic data,"
.W !,"(DOB, Gender, Community of Residene, Tribe)",!
.S DIR(0)="Y",DIR("A")="Do you want to update this patient's demographic information?",DIR("B")="N" KILL DA D ^DIR KILL DIR
.I 'Y Q
.I $D(DIRUT) Q
.S DIE="^BCHRPAT(",DR="[BCH EDIT NON REG PT]",DA=BCHNRPAT D ^DIE K DA,DIE,DR
;UPDATE CHR RECORD FILE
S DA=BCHR,DIE="^BCHR(",DR="1112////"_BCHNRPAT D ^DIE K DA,DIE,DR
Q
ASK ;
S DIR(0)="Y",DIR("A")="Do you wish to EXIT and DELETE this record",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) S BCHQUIT=1 Q
I Y S BCHQUIT=1 Q
G GETPAT
;
RECCHECK ;EP
K BCHOKAY,BCHERROR
S BCHR0=^BCHR(BCHR,0)
I $P(BCHR0,U,2)="" W !,"PROGRAM Missing! " S BCHERROR=1
I $P(BCHR0,U,3)="" W !,"PROVIDER/CHR Missing! " S BCHERROR=1
I $P(BCHR0,U,6)="" W !,"ACTIVITY LOCATION Missing! " S BCHERROR=1
I $P(BCHR0,U,11)="" W !,"TRAVEL TIME Missing!" S BCHERROR=1
I $P(BCHR0,U,12)="" W !,"# SERVED Missing!" S BCHERROR=1
I '$D(^BCHRPROB("AD",BCHR)) W !,"At least one ASSESSMENT/POV is Required and is Missing! " S BCHERROR=1
NEW X,Y
S X=0 F S X=$O(^BCHRPROB("AD",BCHR,X)) Q:X'=+X D
.I $P(^BCHRPROB(X,0),U,1)="" W !,"Assessment Problem code Missing!" S BCHERROR=1
.I $P(^BCHRPROB(X,0),U,4)="" W !,"Service Code for Assessment ",$$VAL^XBDIQ1(90002.01,X,.01)," is Missing!" S BCHERROR=1
.I $P(^BCHRPROB(X,0),U,5)="" W !,"Service Minutes for Assessment ",$$VAL^XBDIQ1(90002.01,X,.01)," is Missing!" S BCHERROR=1
.I $P(^BCHRPROB(X,0),U,6)="" W !,"Narrative for Assessment ",$$VAL^XBDIQ1(90002.01,X,.01)," is Missing!" S BCHERROR=1
I $P(^BCHR(BCHR,0),U,4)="",$P($G(^BCHR(BCHR,11)),U,12)="" G E
I '$P(^BCHR(BCHR,0),U,12) G E ;non patient
I $P(^BCHR(BCHR,0),U,29) G E
I '$O(^BCHR(BCHR,41,0)) W !,"REFERRED TO CHR BY is Missing and is Required! " S BCHERROR=1
I '$O(^BCHR(BCHR,42,0)) W !,"REFERRED BY CHR TO is Missing and is Required! " S BCHERROR=1
E ;do you wish to edit? if not, delete, if yes, go back to edit
Q:'$G(BCHERROR)
S DIR(0)="S^E:Edit the Record and Correct the Error;D:Delete the Record",DIR("A")="Do you wish to",DIR("B")="E" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
I $G(BCHUEDT) D EDIT Q
I Y="D" Q
D GETRECD^BCHUADD
G RECCHECK
EDIT ;
I Y="D" D EXITMSG^BCHUADD S BCHRWDEL=1 Q
D 2^BCHUEDT
G RECCHECK
PROTOCOL ;PEP - announce chr record has been added
Q ;NO PCC LINK PER V2.0 SPECS
D SETARRAY
S X=+$O(^ORD(101,"B","BCH CHR RECORD EVENT",0))_";ORD(101,"
D EN^XQOR
K BCHEV ;kill event array
Q
SETARRAY ;set up array for pcc protocol call
S BCHEV("PKG")=$O(^DIC(9.4,"C","BCH","")),BCHPKG=BCHEV("PKG") ;apcdpkg - system wide, required by pcc link
S BCHEV("SITE")=^BCHSITE(DUZ(2),0) ;pass site parameters
S BCHEV("CHR IEN")=BCHR ;record in CHR RECORD FILE
S BCHEV("DATA0")=^BCHR(BCHR,0)
S BCHEV("DATA12")=$G(^BCHR(BCHR,12))
S BCHEV("DATA13")=$G(^BCHR(BCHR,13))
I $P(BCHEV("DATA0"),U,6) S BCHEV("ACTLOC")=^BCHTACTL($P(BCHEV("DATA0"),U,6),0)
S (X,C)=0 F S X=$O(^BCHRPROB("AD",BCHR,X)) Q:X="" D
.Q:'$D(^BCHRPROB(X,0))
.Q:$P(^BCHRPROB(X,0),U)=""
.Q:$P(^BCHRPROB(X,0),U,4)=""
.Q:$P(^BCHRPROB(X,0),U,6)=""
.S C=C+1,BCHEV("POV",C)=^BCHRPROB(X,0),BCHEV("POV",C,"ICD9")=$P(^BCHTPROB($P(^BCHRPROB(X,0),U),0),U,5),BCHEV("POV",C,"SRV")=^BCHTSERV($P(^BCHRPROB(X,0),U,4),0)
S (X,C)=0 F S X=$O(^BCHRPED("AD",BCHR,X)) Q:X="" D
.Q:'$D(^BCHRPED(X,0))
.Q:$P(^BCHRPED(X,0),U)=""
.S C=C+1,BCHEV("EDUC",C)=^BCHRPED(X,0)
K C,X
Q
UPNONREG ;EP
W !!,"Please select a patient from the Non-Registered Patient Database",!,"or enter a new Non-Registered Patient.",!
S DIC="^BCHRPAT(",DIC(0)="AEMQL" D ^DIC K DIC
;SCREENMAN CALL
;S DIE="^BCHR(",DA=BCHR,DR="1101///"_BCHNAME D ^DIE K DIE,DR,DA,DIU,DIV,DIW
;S DA=BCHR,DDSFILE=90002,DR="[BCH ENTER PATIENT DATA]" D ^DDS
;K DR,DA,DDSFILE,DIC,DIE
;I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q
;Q:$G(^BCHR(BCHR,11))]""
I Y=-1 K DIC,Y Q
S BCHNRPAT=+Y
W !!,"Please review and update if necessary this non-registered patient's data:"
S DIE="^BCHRPAT(",DR="[BCH EDIT NON REG PT]",DA=BCHNRPAT D ^DIE K DA,DIE,DR
Q
BCHUADD1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;IHS/CMI/LAB - fixed dir call to allow 1-30 characters
+3 ;
+4 ;
GETPAT ;EP
+1 IF $DATA(IOF)
WRITE @IOF
WRITE !!!!!?15,"****** P A T I E N T I N F O R M A T I O N ******",!!
+2 WRITE !,"If this encounter involved a particular patient, please enter the patient's",!,"chart # or name now. If this is not a single patient encounter,",!,"but a group encounter or an Non-Patient encounter, simply HIT the"
+3 WRITE !,"ENTER key to exit back and Enter N for All Other Activities.",!
+4 WRITE !,"Please enter the patient information now.",!
+5 SET DFN=""
+6 SET DIR(0)="FO^1:30"
SET DIR("A")="Enter PATIENT NAME or CHART #"
+7 SET DIR("?",1)=" To find a patient, you can enter the patient's chart number;"
+8 SET DIR("?",2)=" lastname,firstname; SSN; or DOB."
+9 SET DIR("?",3)=" "
+10 SET DIR("?",4)=" If the patient cannot be found in the Patient Registration"
+11 SET DIR("?",5)=" database and you would like to capture demographic information"
+12 SET DIR("?",6)=" for this patient into the CHR database, answer NO when asked"
+13 SET DIR("?",7)=" if you would like to try another lookup. You will then be"
+14 SET DIR("?",8)=" given the opportunity to capture the patient's demographic"
+15 SET DIR("?",9)=" data on the following screen."
+16 SET DIR("?",10)=""
+17 SET DIR("?",11)=" Registered patient demographic data can only be edited via the"
+18 SET DIR("?")=" Patient Registration system."
+19 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+20 IF X=""
WRITE !!,"No Patient entered. Required "
GOTO ASK
+21 IF $DATA(DIRUT)
WRITE !,"No patient entered!! - Required."
GOTO ASK
+22 SET (X,BCHNAME)=Y
SET DIC="^AUPNPAT("
SET DIC(0)="MQE"
DO ^DIC
KILL DIC
+23 ;I X="" W !!,"No Patient entered. If this is not a patient related encounter use the ",!,"'All Other Activities option'.",! D PAUSE^BCHUTIL1 Q
+24 IF Y=-1
DO NOREG
QUIT
+25 WRITE !?25,"Ok"
SET %=1
DO YN^DICN
IF %'=1
WRITE !!,"Try again.",!
GOTO GETPAT
+26 SET DFN=+Y
DO DIRX^BCHUADD
SET BCHF=".04"
SET BCHV=""
+27 SET DIE="^BCHR("
SET DA=BCHR
SET DR=".04///`"_DFN
DO ^DIE
KILL DA,DIE,DR
+28 IF $DATA(Y)
WRITE !!,"PATIENT NOT VALID! TRY AGAIN"
KILL Y
GOTO GETPAT
+29 QUIT
+30 ;
NOREG ;
+1 WRITE !,"That patient cannot be found in the Registration database."
+2 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Do you want to try to lookup the patient in registration again"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
WRITE !,"Exiting..."
SET BCHQUIT=1
QUIT
+4 IF Y
GOTO GETPAT
+5 WRITE !!,"Please select a patient from the Non-Registered Patient Database",!,"or enter a new Non-Registered Patient.",!
+6 SET DIC("B")=BCHNAME
SET DIC="^BCHRPAT("
SET DIC(0)="AEMQL"
DO ^DIC
KILL DIC
+7 ;SCREENMAN CALL
+8 ;S DIE="^BCHR(",DA=BCHR,DR="1101///"_BCHNAME D ^DIE K DIE,DR,DA,DIU,DIV,DIW
+9 ;S DA=BCHR,DDSFILE=90002,DR="[BCH ENTER PATIENT DATA]" D ^DDS
+10 ;K DR,DA,DDSFILE,DIC,DIE
+11 ;I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q
+12 ;Q:$G(^BCHR(BCHR,11))]""
+13 IF Y=-1
WRITE !!,"A patient is Required"
GOTO ASK
+14 SET BCHNRPAT=+Y
+15 IF $PIECE(Y,U,3)
Begin DoDot:1
+16 WRITE !!,"Please review and update if necessary this non-registered patient's data:"
+17 SET DIE="^BCHRPAT("
SET DR="[BCH EDIT NON REG PT]"
SET DA=BCHNRPAT
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
IF 1
+18 IF '$TEST
Begin DoDot:1
+19 WRITE !!,"You now have the opportunity to update this patient's demographic data,"
+20 WRITE !,"(DOB, Gender, Community of Residene, Tribe)",!
+21 SET DIR(0)="Y"
SET DIR("A")="Do you want to update this patient's demographic information?"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+22 IF 'Y
QUIT
+23 IF $DATA(DIRUT)
QUIT
+24 SET DIE="^BCHRPAT("
SET DR="[BCH EDIT NON REG PT]"
SET DA=BCHNRPAT
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+25 ;UPDATE CHR RECORD FILE
+26 SET DA=BCHR
SET DIE="^BCHR("
SET DR="1112////"_BCHNRPAT
DO ^DIE
KILL DA,DIE,DR
+27 QUIT
ASK ;
+1 SET DIR(0)="Y"
SET DIR("A")="Do you wish to EXIT and DELETE this record"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
SET BCHQUIT=1
QUIT
+3 IF Y
SET BCHQUIT=1
QUIT
+4 GOTO GETPAT
+5 ;
RECCHECK ;EP
+1 KILL BCHOKAY,BCHERROR
+2 SET BCHR0=^BCHR(BCHR,0)
+3 IF $PIECE(BCHR0,U,2)=""
WRITE !,"PROGRAM Missing! "
SET BCHERROR=1
+4 IF $PIECE(BCHR0,U,3)=""
WRITE !,"PROVIDER/CHR Missing! "
SET BCHERROR=1
+5 IF $PIECE(BCHR0,U,6)=""
WRITE !,"ACTIVITY LOCATION Missing! "
SET BCHERROR=1
+6 IF $PIECE(BCHR0,U,11)=""
WRITE !,"TRAVEL TIME Missing!"
SET BCHERROR=1
+7 IF $PIECE(BCHR0,U,12)=""
WRITE !,"# SERVED Missing!"
SET BCHERROR=1
+8 IF '$DATA(^BCHRPROB("AD",BCHR))
WRITE !,"At least one ASSESSMENT/POV is Required and is Missing! "
SET BCHERROR=1
+9 NEW X,Y
+10 SET X=0
FOR
SET X=$ORDER(^BCHRPROB("AD",BCHR,X))
IF X'=+X
QUIT
Begin DoDot:1
+11 IF $PIECE(^BCHRPROB(X,0),U,1)=""
WRITE !,"Assessment Problem code Missing!"
SET BCHERROR=1
+12 IF $PIECE(^BCHRPROB(X,0),U,4)=""
WRITE !,"Service Code for Assessment ",$$VAL^XBDIQ1(90002.01,X,.01)," is Missing!"
SET BCHERROR=1
+13 IF $PIECE(^BCHRPROB(X,0),U,5)=""
WRITE !,"Service Minutes for Assessment ",$$VAL^XBDIQ1(90002.01,X,.01)," is Missing!"
SET BCHERROR=1
+14 IF $PIECE(^BCHRPROB(X,0),U,6)=""
WRITE !,"Narrative for Assessment ",$$VAL^XBDIQ1(90002.01,X,.01)," is Missing!"
SET BCHERROR=1
End DoDot:1
+15 IF $PIECE(^BCHR(BCHR,0),U,4)=""
IF $PIECE($GET(^BCHR(BCHR,11)),U,12)=""
GOTO E
+16 ;non patient
IF '$PIECE(^BCHR(BCHR,0),U,12)
GOTO E
+17 IF $PIECE(^BCHR(BCHR,0),U,29)
GOTO E
+18 IF '$ORDER(^BCHR(BCHR,41,0))
WRITE !,"REFERRED TO CHR BY is Missing and is Required! "
SET BCHERROR=1
+19 IF '$ORDER(^BCHR(BCHR,42,0))
WRITE !,"REFERRED BY CHR TO is Missing and is Required! "
SET BCHERROR=1
E ;do you wish to edit? if not, delete, if yes, go back to edit
+1 IF '$GET(BCHERROR)
QUIT
+2 SET DIR(0)="S^E:Edit the Record and Correct the Error;D:Delete the Record"
SET DIR("A")="Do you wish to"
SET DIR("B")="E"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
QUIT
+4 IF $GET(BCHUEDT)
DO EDIT
QUIT
+5 IF Y="D"
QUIT
+6 DO GETRECD^BCHUADD
+7 GOTO RECCHECK
EDIT ;
+1 IF Y="D"
DO EXITMSG^BCHUADD
SET BCHRWDEL=1
QUIT
+2 DO 2^BCHUEDT
+3 GOTO RECCHECK
PROTOCOL ;PEP - announce chr record has been added
+1 ;NO PCC LINK PER V2.0 SPECS
QUIT
+2 DO SETARRAY
+3 SET X=+$ORDER(^ORD(101,"B","BCH CHR RECORD EVENT",0))_";ORD(101,"
+4 DO EN^XQOR
+5 ;kill event array
KILL BCHEV
+6 QUIT
SETARRAY ;set up array for pcc protocol call
+1 ;apcdpkg - system wide, required by pcc link
SET BCHEV("PKG")=$ORDER(^DIC(9.4,"C","BCH",""))
SET BCHPKG=BCHEV("PKG")
+2 ;pass site parameters
SET BCHEV("SITE")=^BCHSITE(DUZ(2),0)
+3 ;record in CHR RECORD FILE
SET BCHEV("CHR IEN")=BCHR
+4 SET BCHEV("DATA0")=^BCHR(BCHR,0)
+5 SET BCHEV("DATA12")=$GET(^BCHR(BCHR,12))
+6 SET BCHEV("DATA13")=$GET(^BCHR(BCHR,13))
+7 IF $PIECE(BCHEV("DATA0"),U,6)
SET BCHEV("ACTLOC")=^BCHTACTL($PIECE(BCHEV("DATA0"),U,6),0)
+8 SET (X,C)=0
FOR
SET X=$ORDER(^BCHRPROB("AD",BCHR,X))
IF X=""
QUIT
Begin DoDot:1
+9 IF '$DATA(^BCHRPROB(X,0))
QUIT
+10 IF $PIECE(^BCHRPROB(X,0),U)=""
QUIT
+11 IF $PIECE(^BCHRPROB(X,0),U,4)=""
QUIT
+12 IF $PIECE(^BCHRPROB(X,0),U,6)=""
QUIT
+13 SET C=C+1
SET BCHEV("POV",C)=^BCHRPROB(X,0)
SET BCHEV("POV",C,"ICD9")=$PIECE(^BCHTPROB($PIECE(^BCHRPROB(X,0),U),0),U,5)
SET BCHEV("POV",C,"SRV")=^BCHTSERV($PIECE(^BCHRPROB(X,0),U,4),0)
End DoDot:1
+14 SET (X,C)=0
FOR
SET X=$ORDER(^BCHRPED("AD",BCHR,X))
IF X=""
QUIT
Begin DoDot:1
+15 IF '$DATA(^BCHRPED(X,0))
QUIT
+16 IF $PIECE(^BCHRPED(X,0),U)=""
QUIT
+17 SET C=C+1
SET BCHEV("EDUC",C)=^BCHRPED(X,0)
End DoDot:1
+18 KILL C,X
+19 QUIT
UPNONREG ;EP
+1 WRITE !!,"Please select a patient from the Non-Registered Patient Database",!,"or enter a new Non-Registered Patient.",!
+2 SET DIC="^BCHRPAT("
SET DIC(0)="AEMQL"
DO ^DIC
KILL DIC
+3 ;SCREENMAN CALL
+4 ;S DIE="^BCHR(",DA=BCHR,DR="1101///"_BCHNAME D ^DIE K DIE,DR,DA,DIU,DIV,DIW
+5 ;S DA=BCHR,DDSFILE=90002,DR="[BCH ENTER PATIENT DATA]" D ^DDS
+6 ;K DR,DA,DDSFILE,DIC,DIE
+7 ;I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q
+8 ;Q:$G(^BCHR(BCHR,11))]""
+9 IF Y=-1
KILL DIC,Y
QUIT
+10 SET BCHNRPAT=+Y
+11 WRITE !!,"Please review and update if necessary this non-registered patient's data:"
+12 SET DIE="^BCHRPAT("
SET DR="[BCH EDIT NON REG PT]"
SET DA=BCHNRPAT
DO ^DIE
KILL DA,DIE,DR
+13 QUIT
