Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BCHUADD

BCHUADD.m

Go to the documentation of this file.
  1. BCHUADD ; IHS/CMI/LAB - ADD NEW CHR ACTIVITY RECORDS ;
  1. ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
  1. ;
  1. ;add new records
  1. ;get all items for a record, check record, file record
  1. ;if not complete record, issue warning and delete record
  1. ADDR ;EP
  1. D FULL^VALM1
  1. I '$D(BCHPROV) W !!,"Provider not entered." Q
  1. I '$D(BCHDATE) W !!,"Date not entered." Q
  1. I '$D(BCHPROG) W !!,"Program not entered." Q
  1. S BCHQUIT=0
  1. ;create record with DICN
  1. ;use abbreviated form or regular form
  1. ;patient or not
  1. PNP ;
  1. S BCHPNP="",DFN=""
  1. 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
  1. I $D(DIRUT) D EXIT Q
  1. I Y="Q" D EXIT Q
  1. S BCHPNP=Y
  1. D CREATE
  1. I BCHQUIT D EXIT Q
  1. I BCHPNP="P" D GETPAT I BCHQUIT D EXITMSG,EXIT Q
  1. RECD ;
  1. D GETRECD
  1. I BCHQUIT D EXITMSG,EXIT Q
  1. D RECCHECK^BCHUADD1
  1. I $D(BCHERROR) D EXITMSG,EXIT Q
  1. MEAS ;
  1. ;I BCHPNP D GETMEAS
  1. CHECK ;check record
  1. ;DO PCC LINK
  1. ;S BCHEV("TYPE")="A" ;add,edit or delete
  1. ;D PROTOCOL^BCHUADD1 ;protocol to announce chr record event
  1. D EXIT
  1. Q
  1. CREATE ;create new record
  1. 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"
  1. S DIC(0)="EL",DIC="^BCHR(",DLAYGO=90002,DIADD=1,X=BCHDATE K DD,DO D FILE^DICN D FMKILL
  1. 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
  1. S BCHR=+Y
  1. Q
  1. GETPAT ; GET PATIENT
  1. D GETPAT^BCHUADD1
  1. Q
  1. GETRECD ;EP
  1. S APCDOVRR=""
  1. W !
  1. 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
  1. 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
  1. ;I '$G(DDSSAVE) W !,"Record Not Saved (F1 Q), deleting record." S BCHERROR=1 Q
  1. ;backfill pt ptr in CHR POV
  1. D
  1. .S BCHX=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX D
  1. ..K ^BCHRPROB(BCHX,81) ;kill off temp node
  1. ..K ^BCHRPROB(BCHX,92)
  1. ..Q:BCHPNP'="P"
  1. ..Q:'$G(DFN)
  1. ..S DIE="^BCHRPROB(",DA=BCHX,DR=".02////"_DFN_";.09///@",DITC=""
  1. ..D ^DIE
  1. ..K DIE,DA,DR,DIU,DIV,DIW,DIY,DITC
  1. ..I $D(Y) W !,"error updating pov's with patient, NOTIFY PROGRAMMER" H 5
  1. ..Q
  1. .Q:'DFN
  1. .K BCHX
  1. .S BCHX=0 F S BCHX=$O(^BCHRPED("AD",BCHR,BCHX)) Q:BCHX'=+BCHX D
  1. ..S DIE="^BCHRPED(",DA=BCHX,DR=".02////"_DFN,DITC=""
  1. ..D ^DIE
  1. ..K DIE,DA,DR,DIU,DIV,DIW,DIY,DITC
  1. ..I $D(Y) W !,"error updating education's with patient, NOTIFY PROGRAMMER" H 5
  1. ..Q
  1. D FMKILL
  1. I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q
  1. Q
  1. GETSUBJ ;
  1. S DIR(0)="Y",DIR("A")="Do you want to enter SUBJECTIVE/OBJECTIVE INFORMATION",DIR("B")="N" K DA D ^DIR K DIR
  1. Q:$D(DIRUT)
  1. Q:'Y
  1. S DA=BCHR,DDSFILE=90002,DR="[BCH ENTER/EDIT SUBJ/OBJ]" D ^DDS
  1. D FMKILL
  1. I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q
  1. Q
  1. GETMEAS ;
  1. I BCHPNP'="P" Q ;not patient
  1. I '$D(DFN),'$G(^BCHR(BCHR,11))="" Q ;no patient so no measurements
  1. ;I 'BCHPTSV Q ;no patient related services so no measurements
  1. W !
  1. 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
  1. Q:$D(DIRUT)
  1. Q:'Y
  1. S DA=BCHR,DDSFILE=90002,DR=$S('$G(BCHUABFO):"[BCH ENTER MEASUREMENTS/TESTS]",1:"[BCHB ENTER MEASUREMENTS/TESTS") D ^DDS
  1. D FMKILL
  1. I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q
  1. Q
  1. DEL ;
  1. S BCHVDLT=$P(^BCHR(BCHR,0),U,15)
  1. S BCHRDEL=BCHR
  1. D EN^BCHUDEL
  1. W !,"Record deleted." D PAUSE^BCHUTIL1
  1. Q
  1. DR ;set up BCHDR string
  1. I '$D(BCHDR) S BCHDR=""
  1. I BCHDR="" S BCHDR=BCHF_"///"_BCHV
  1. S BCHDR=BCHDR_";"_BCHF_"///"_BCHV
  1. Q
  1. FMKILL ;EP
  1. K DIE,DR,DA,D,DIU,DIY,DIV,DIW,DIG,DDSFILE,DIC,DIADD,DLAYGO,X,D0,DD,D1,DO
  1. Q
  1. DIRX ;EP
  1. K DIR,X,Y,DIC,DA,DIRUT,DUOUT,DTOUT,DIG
  1. K BCHF,BCHV
  1. Q
  1. EXITMSG ;EP - display message, delete record, q
  1. W !,"Incomplete record. Deleting record. " D DEL
  1. Q
  1. EXIT ;CLEAN UP AND EXIT
  1. D TERM^VALM0
  1. S VALMBCK="R"
  1. D GATHER^BCHUARL
  1. S VALMCNT=BCHRCNT
  1. D HDR^BCHUAR
  1. K BCHV,BCHF,BCHDR,DFN,BCHR,BCHQUIT,BCHRDEL,BCHV,BCHVDLT,BCHNAME,BCHPTSV,BCHX,DFN,BCHERROR,BCHR0,BCHPNP
  1. D DIRX^BCHUADD,FMKILL^BCHUADD
  1. Q
  1. ;
  1. BV ;EP - called from protocol
  1. D ^BCHVD
  1. D EXIT
  1. Q
  1. NF(R) ;not found?
  1. I '$G(R) Q ""
  1. NEW X,Y
  1. 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
  1. Q Y