BCHUADD ; IHS/CMI/LAB - ADD NEW CHR ACTIVITY RECORDS ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;
;add new records
;get all items for a record, check record, file record
;if not complete record, issue warning and delete record
ADDR ;EP
D FULL^VALM1
I '$D(BCHPROV) W !!,"Provider not entered." Q
I '$D(BCHDATE) W !!,"Date not entered." Q
I '$D(BCHPROG) W !!,"Program not entered." Q
S BCHQUIT=0
;create record with DICN
;use abbreviated form or regular form
;patient or not
PNP ;
S BCHPNP="",DFN=""
S DIR(0)="S^P:Individual Patient Encounter Record;N:All Other Activities;Q:QUIT, GO BACK",DIR("A")="Which Type of Record",DIR("B")="P" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT Q
I Y="Q" D EXIT Q
S BCHPNP=Y
D CREATE
I BCHQUIT D EXIT Q
I BCHPNP="P" D GETPAT I BCHQUIT D EXITMSG,EXIT Q
RECD ;
D GETRECD
I BCHQUIT D EXITMSG,EXIT Q
D RECCHECK^BCHUADD1
I $D(BCHERROR) D EXITMSG,EXIT Q
MEAS ;
;I BCHPNP D GETMEAS
CHECK ;check record
;DO PCC LINK
;S BCHEV("TYPE")="A" ;add,edit or delete
;D PROTOCOL^BCHUADD1 ;protocol to announce chr record event
D EXIT
Q
CREATE ;create new record
W !,"Creating new CHR record...",! K DD,D0,DO,DINUM,DIC,DA,DR S DIC("DR")=".02////"_+BCHPROG_";.03////"_+BCHPROV_";.16////"_DUZ_";.22///^S X=DT;.26///H;.17///^S X=DT"
S DIC(0)="EL",DIC="^BCHR(",DLAYGO=90002,DIADD=1,X=BCHDATE K DD,DO D FILE^DICN D FMKILL
I Y=-1 W !!,$C(7),$C(7),"Unable to create CHR Record record, record not complete!! Deleting Record.",! D DEL S BCHQUIT=1 Q
S BCHR=+Y
Q
GETPAT ; GET PATIENT
D GETPAT^BCHUADD1
Q
GETRECD ;EP
S APCDOVRR=""
W !
I BCHPNP="P" S DDSPARM="S",DA=BCHR,DDSFILE=90002,DR=$S('$G(BCHUABFO):"[BCHQ1 ENTER CHR DATA (535)]",1:"[BCHAQ1 ENTER CHR DATA (535)]") D ^DDS
I BCHPNP="N" S DDSPARM="S",DA=BCHR,DDSFILE=90002,DR=$S('$G(BCHUABFO):"[BCHNP1 ENTER CHR DATA (535)]",1:"[BCHNP1 ENTER CHR DATA (535)]") D ^DDS
;I '$G(DDSSAVE) W !,"Record Not Saved (F1 Q), deleting record." S BCHERROR=1 Q
;backfill pt ptr in CHR POV
D
.S BCHX=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX D
..K ^BCHRPROB(BCHX,81) ;kill off temp node
..K ^BCHRPROB(BCHX,92)
..Q:BCHPNP'="P"
..Q:'$G(DFN)
..S DIE="^BCHRPROB(",DA=BCHX,DR=".02////"_DFN_";.09///@",DITC=""
..D ^DIE
..K DIE,DA,DR,DIU,DIV,DIW,DIY,DITC
..I $D(Y) W !,"error updating pov's with patient, NOTIFY PROGRAMMER" H 5
..Q
.Q:'DFN
.K BCHX
.S BCHX=0 F S BCHX=$O(^BCHRPED("AD",BCHR,BCHX)) Q:BCHX'=+BCHX D
..S DIE="^BCHRPED(",DA=BCHX,DR=".02////"_DFN,DITC=""
..D ^DIE
..K DIE,DA,DR,DIU,DIV,DIW,DIY,DITC
..I $D(Y) W !,"error updating education's with patient, NOTIFY PROGRAMMER" H 5
..Q
D FMKILL
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q
Q
GETSUBJ ;
S DIR(0)="Y",DIR("A")="Do you want to enter SUBJECTIVE/OBJECTIVE INFORMATION",DIR("B")="N" K DA D ^DIR K DIR
Q:$D(DIRUT)
Q:'Y
S DA=BCHR,DDSFILE=90002,DR="[BCH ENTER/EDIT SUBJ/OBJ]" D ^DDS
D FMKILL
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q
Q
GETMEAS ;
I BCHPNP'="P" Q ;not patient
I '$D(DFN),'$G(^BCHR(BCHR,11))="" Q ;no patient so no measurements
;I 'BCHPTSV Q ;no patient related services so no measurements
W !
S DIR(0)="Y",DIR("A")=$S('$G(BCHUABFO):"Any MEASUREMENTS, TESTS or REPRODUCTIVE FACTORS",1:"Any MEASUREMENTS/TESTS"),DIR("B")="Y" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
Q:'Y
S DA=BCHR,DDSFILE=90002,DR=$S('$G(BCHUABFO):"[BCH ENTER MEASUREMENTS/TESTS]",1:"[BCHB ENTER MEASUREMENTS/TESTS") D ^DDS
D FMKILL
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q
Q
DEL ;
S BCHVDLT=$P(^BCHR(BCHR,0),U,15)
S BCHRDEL=BCHR
D EN^BCHUDEL
W !,"Record deleted." D PAUSE^BCHUTIL1
Q
DR ;set up BCHDR string
I '$D(BCHDR) S BCHDR=""
I BCHDR="" S BCHDR=BCHF_"///"_BCHV
S BCHDR=BCHDR_";"_BCHF_"///"_BCHV
Q
FMKILL ;EP
K DIE,DR,DA,D,DIU,DIY,DIV,DIW,DIG,DDSFILE,DIC,DIADD,DLAYGO,X,D0,DD,D1,DO
Q
DIRX ;EP
K DIR,X,Y,DIC,DA,DIRUT,DUOUT,DTOUT,DIG
K BCHF,BCHV
Q
EXITMSG ;EP - display message, delete record, q
W !,"Incomplete record. Deleting record. " D DEL
Q
EXIT ;CLEAN UP AND EXIT
D TERM^VALM0
S VALMBCK="R"
D GATHER^BCHUARL
S VALMCNT=BCHRCNT
D HDR^BCHUAR
K BCHV,BCHF,BCHDR,DFN,BCHR,BCHQUIT,BCHRDEL,BCHV,BCHVDLT,BCHNAME,BCHPTSV,BCHX,DFN,BCHERROR,BCHR0,BCHPNP
D DIRX^BCHUADD,FMKILL^BCHUADD
Q
;
BV ;EP - called from protocol
D ^BCHVD
D EXIT
Q
NF(R) ;not found?
I '$G(R) Q ""
NEW X,Y
S (X,Y)=0 F S X=$O(^BCHRPROB("AD",R,X)) Q:X'=+X!(Y) I $P(^BCHRPROB(X,0),U,4)]"",$P(^BCHTSERV($P(^BCHRPROB(X,0),U,4),0),U,3)="NF" S Y=1
Q Y
BCHUADD ; IHS/CMI/LAB - ADD NEW CHR ACTIVITY RECORDS ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;
+3 ;add new records
+4 ;get all items for a record, check record, file record
+5 ;if not complete record, issue warning and delete record
ADDR ;EP
+1 DO FULL^VALM1
+2 IF '$DATA(BCHPROV)
WRITE !!,"Provider not entered."
QUIT
+3 IF '$DATA(BCHDATE)
WRITE !!,"Date not entered."
QUIT
+4 IF '$DATA(BCHPROG)
WRITE !!,"Program not entered."
QUIT
+5 SET BCHQUIT=0
+6 ;create record with DICN
+7 ;use abbreviated form or regular form
+8 ;patient or not
PNP ;
+1 SET BCHPNP=""
SET DFN=""
+2 SET DIR(0)="S^P:Individual Patient Encounter Record;N:All Other Activities;Q:QUIT, GO BACK"
SET DIR("A")="Which Type of Record"
SET DIR("B")="P"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
DO EXIT
QUIT
+4 IF Y="Q"
DO EXIT
QUIT
+5 SET BCHPNP=Y
+6 DO CREATE
+7 IF BCHQUIT
DO EXIT
QUIT
+8 IF BCHPNP="P"
DO GETPAT
IF BCHQUIT
DO EXITMSG
DO EXIT
QUIT
RECD ;
+1 DO GETRECD
+2 IF BCHQUIT
DO EXITMSG
DO EXIT
QUIT
+3 DO RECCHECK^BCHUADD1
+4 IF $DATA(BCHERROR)
DO EXITMSG
DO EXIT
QUIT
MEAS ;
+1 ;I BCHPNP D GETMEAS
CHECK ;check record
+1 ;DO PCC LINK
+2 ;S BCHEV("TYPE")="A" ;add,edit or delete
+3 ;D PROTOCOL^BCHUADD1 ;protocol to announce chr record event
+4 DO EXIT
+5 QUIT
CREATE ;create new record
+1 WRITE !,"Creating new CHR record...",!
KILL DD,D0,DO,DINUM,DIC,DA,DR
SET DIC("DR")=".02////"_+BCHPROG_";.03////"_+BCHPROV_";.16////"_DUZ_";.22///^S X=DT;.26///H;.17///^S X=DT"
+2 SET DIC(0)="EL"
SET DIC="^BCHR("
SET DLAYGO=90002
SET DIADD=1
SET X=BCHDATE
KILL DD,DO
DO FILE^DICN
DO FMKILL
+3 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"Unable to create CHR Record record, record not complete!! Deleting Record.",!
DO DEL
SET BCHQUIT=1
QUIT
+4 SET BCHR=+Y
+5 QUIT
GETPAT ; GET PATIENT
+1 DO GETPAT^BCHUADD1
+2 QUIT
GETRECD ;EP
+1 SET APCDOVRR=""
+2 WRITE !
+3 IF BCHPNP="P"
SET DDSPARM="S"
SET DA=BCHR
SET DDSFILE=90002
SET DR=$SELECT('$GET(BCHUABFO):"[BCHQ1 ENTER CHR DATA (535)]",1:"[BCHAQ1 ENTER CHR DATA (535)]")
DO ^DDS
+4 IF BCHPNP="N"
SET DDSPARM="S"
SET DA=BCHR
SET DDSFILE=90002
SET DR=$SELECT('$GET(BCHUABFO):"[BCHNP1 ENTER CHR DATA (535)]",1:"[BCHNP1 ENTER CHR DATA (535)]")
DO ^DDS
+5 ;I '$G(DDSSAVE) W !,"Record Not Saved (F1 Q), deleting record." S BCHERROR=1 Q
+6 ;backfill pt ptr in CHR POV
+7 Begin DoDot:1
+8 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHRPROB("AD",BCHR,BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:2
+9 ;kill off temp node
KILL ^BCHRPROB(BCHX,81)
+10 KILL ^BCHRPROB(BCHX,92)
+11 IF BCHPNP'="P"
QUIT
+12 IF '$GET(DFN)
QUIT
+13 SET DIE="^BCHRPROB("
SET DA=BCHX
SET DR=".02////"_DFN_";.09///@"
SET DITC=""
+14 DO ^DIE
+15 KILL DIE,DA,DR,DIU,DIV,DIW,DIY,DITC
+16 IF $DATA(Y)
WRITE !,"error updating pov's with patient, NOTIFY PROGRAMMER"
HANG 5
+17 QUIT
End DoDot:2
+18 IF 'DFN
QUIT
+19 KILL BCHX
+20 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHRPED("AD",BCHR,BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:2
+21 SET DIE="^BCHRPED("
SET DA=BCHX
SET DR=".02////"_DFN
SET DITC=""
+22 DO ^DIE
+23 KILL DIE,DA,DR,DIU,DIV,DIW,DIY,DITC
+24 IF $DATA(Y)
WRITE !,"error updating education's with patient, NOTIFY PROGRAMMER"
HANG 5
+25 QUIT
End DoDot:2
End DoDot:1
+26 DO FMKILL
+27 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET BCHQUIT=1
KILL DIMSG
QUIT
+28 QUIT
GETSUBJ ;
+1 SET DIR(0)="Y"
SET DIR("A")="Do you want to enter SUBJECTIVE/OBJECTIVE INFORMATION"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
QUIT
+3 IF 'Y
QUIT
+4 SET DA=BCHR
SET DDSFILE=90002
SET DR="[BCH ENTER/EDIT SUBJ/OBJ]"
DO ^DDS
+5 DO FMKILL
+6 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET BCHQUIT=1
KILL DIMSG
QUIT
+7 QUIT
GETMEAS ;
+1 ;not patient
IF BCHPNP'="P"
QUIT
+2 ;no patient so no measurements
IF '$DATA(DFN)
IF '$GET(^BCHR(BCHR,11))=""
QUIT
+3 ;I 'BCHPTSV Q ;no patient related services so no measurements
+4 WRITE !
+5 SET DIR(0)="Y"
SET DIR("A")=$SELECT('$GET(BCHUABFO):"Any MEASUREMENTS, TESTS or REPRODUCTIVE FACTORS",1:"Any MEASUREMENTS/TESTS")
SET DIR("B")="Y"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+6 IF $DATA(DIRUT)
QUIT
+7 IF 'Y
QUIT
+8 SET DA=BCHR
SET DDSFILE=90002
SET DR=$SELECT('$GET(BCHUABFO):"[BCH ENTER MEASUREMENTS/TESTS]",1:"[BCHB ENTER MEASUREMENTS/TESTS")
DO ^DDS
+9 DO FMKILL
+10 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET BCHQUIT=1
KILL DIMSG
QUIT
+11 QUIT
DEL ;
+1 SET BCHVDLT=$PIECE(^BCHR(BCHR,0),U,15)
+2 SET BCHRDEL=BCHR
+3 DO EN^BCHUDEL
+4 WRITE !,"Record deleted."
DO PAUSE^BCHUTIL1
+5 QUIT
DR ;set up BCHDR string
+1 IF '$DATA(BCHDR)
SET BCHDR=""
+2 IF BCHDR=""
SET BCHDR=BCHF_"///"_BCHV
+3 SET BCHDR=BCHDR_";"_BCHF_"///"_BCHV
+4 QUIT
FMKILL ;EP
+1 KILL DIE,DR,DA,D,DIU,DIY,DIV,DIW,DIG,DDSFILE,DIC,DIADD,DLAYGO,X,D0,DD,D1,DO
+2 QUIT
DIRX ;EP
+1 KILL DIR,X,Y,DIC,DA,DIRUT,DUOUT,DTOUT,DIG
+2 KILL BCHF,BCHV
+3 QUIT
EXITMSG ;EP - display message, delete record, q
+1 WRITE !,"Incomplete record. Deleting record. "
DO DEL
+2 QUIT
EXIT ;CLEAN UP AND EXIT
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO GATHER^BCHUARL
+4 SET VALMCNT=BCHRCNT
+5 DO HDR^BCHUAR
+6 KILL BCHV,BCHF,BCHDR,DFN,BCHR,BCHQUIT,BCHRDEL,BCHV,BCHVDLT,BCHNAME,BCHPTSV,BCHX,DFN,BCHERROR,BCHR0,BCHPNP
+7 DO DIRX^BCHUADD
DO FMKILL^BCHUADD
+8 QUIT
+9 ;
BV ;EP - called from protocol
+1 DO ^BCHVD
+2 DO EXIT
+3 QUIT
NF(R) ;not found?
+1 IF '$GET(R)
QUIT ""
+2 NEW X,Y
+3 SET (X,Y)=0
FOR
SET X=$ORDER(^BCHRPROB("AD",R,X))
IF X'=+X!(Y)
QUIT
IF $PIECE(^BCHRPROB(X,0),U,4)]""
IF $PIECE(^BCHTSERV($PIECE(^BCHRPROB(X,0),U,4),0),U,3)="NF"
SET Y=1
+4 QUIT Y
