- 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