BCHEGR ; IHS/CMI/LAB - GROUP ENTRY 08 Nov 2011 3:34 PM ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;
;
START ;
W:$D(IOF) @IOF
D DONE
;
DATES ;
W !!,"You will be presented with a list of group definitions for the"
W !,"CHR you select for the date range you select. You will then"
W !,"be able to select one of the group definitions which will be "
W !,"duplicated and used as a template for the group data you are "
W !,"about to enter.",!
S BCHPROV=""
D GETPROV^BCHUAR
I 'BCHPROV D DONE Q
K BCHRED,BCHRBD
W !,"Please enter the date range for displaying Group definitions."
K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date"
D ^DIR Q:Y<1 S BCHRBD=Y
K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date"
D ^DIR Q:Y<1 S BCHRED=Y
;
I BCHRED<BCHRBD D G DATES
. W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
;
;
D EN,FULL^VALM1
D DONE
Q
DONE ;
D EN^XBVK("BCH")
D ^XBFMK
D KILL^AUPNPAT
Q
EN ;
K ^TMP($J,"BCHEGR")
D GATHER
D EN^VALM("BCH GROUP ENTRY")
D CLEAR^VALM1
Q
GATHER ;
D GATHER^BCHEGR1
Q
CTR(X,Y) ;EP - Center
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
HDR ; -- header code
S VALMHDR(1)="Group Entry"
S X="",$E(X,7)="Date",$E(X,16)="Group Name",$E(X,37)="CHR",$E(X,54)="# SERVED",$E(X,63)="ASSESSMENTS"
S VALMHDR(2)=X
Q
;
INIT ;
D GATHER
S VALMCNT=BCHLINE
Q
;lori edit
HELP ;
S X="?" D DISP^XQORM1 W !!
Q
;
EXPND ; -- expand code
Q
EDITDEF ;
D FULL^VALM1
W !!,"This action should be used to edit a group definition only. If visits have"
W !,"already been entered for this group, you will not be able to edit the group"
W !,"definition.",!
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." D EXIT Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT Q
S BCHNG=0 S BCHNG=^TMP($J,"BCHEGR","IDX",R,R)
I '$D(^BCHGRPD(BCHNG,0)) W !,"Not a valid GROUP." K BCHNG,R,BCHG,R1 D PAUSE D EXIT Q
D FULL^VALM1
I $O(^BCHGRPD(BCHNG,61,0)) W !!,"This group already has visits created. You must use the REVIEW/EDIT",!,"GROUP VISITS to modify visits within this group." D PAUSE,EXIT Q
I $P(^BCHGRPD(BCHNG,0),U,18) W !!,"This Group's Notes have been signed. You cannot edit the Group.",! D PAUSE,EXIT Q
S BCHDATE=$P($P(^BCHGRPD(BCHNG,0),U),".")
D EDITGRP
Q
ADDGRP ;
D FULL^VALM1
;add new group
K DIR S DIR(0)="D^:"_DT_":EP",DIR("A")="Enter Date of the Group Activity" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !,"date not entered." D PAUSE,EXIT Q
S BCHDATE=Y
S X=BCHDATE,DIC="^BCHGRPD(",DLAYGO=90002.67,DIADD=1,DIC(0)="L",DIC("DR")=".07////"_BCHPROV_";.04////"_DT_";.12////"_DUZ K DD,DO D FILE^DICN
I Y=-1 W !!,"entry of new group failed." K DIADD,DLAYGO D ^XBFMK D EXIT Q
S BCHNG=+Y
K DIADD,DLAYGO D ^XBFMK
EDITGRP ;EP
S APCDOVRR=1
S DA=BCHNG,DDSFILE=90002.67,DR="[BCH EDIT GROUP DEFINITION]" D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG D PAUSE,EXIT Q
;must have a pov/provider
S E=0
I $P(^BCHGRPD(BCHNG,0),U,7)="" W !!,"Group must have CHR defined." S E=1
NEW X,G,C
I '$O(^BCHGRPDA("AD",BCHNG,0)) W !!,"Group must have at least one POV defined." S E=1
I E S BCHE="" D G:BCHE="E" EDITGRP D:BCHE="Q" PAUSE,EXIT Q:BCHE="Q" W !!,"deleting group definition." S DA=BCHNG,DIK="^BCHGRPD(" D ^DIK D PAUSE,EXIT Q
.S DIR(0)="S^E:Edit the Group definition;D:Delete this Group definition;Q:to exit and edit it later without deleting the group definition",DIR("A")="This group definition is not complete, do you wish to",DIR("B")="E" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) Q
.S BCHE=Y
.Q
;now loop and get patients for the group
D ^XBFMK
W !!,"You have added the following group definition, please review it carefully",!,"before you proceed to add/update the patients in the group.",!
D DISP2^BCHEGR1
S DIR(0)="S^Y:Yes-group definition is accurate-continue to Patient List;N:No, I wish to edit the group definition;Q:I wish to QUIT and exit",DIR("A")="Do you wish to continue on to add patient visits for this group"
S DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D PAUSE,EXIT Q
I Y="Q" D DELGRP,PAUSE,EXIT Q
I Y="N" G EDITGRP
SENS ;check for sensitive patients
K BCHPAT
W !!!
W !,"You will be prompted to confirm the list of patients who were in the"
W !,$$VAL^XBDIQ1(90002.67,BCHNG,.03)," group on ",$$VAL^XBDIQ1(90002.67,BCHNG,.01),".",!
S BCHQ=""
D GETPATS
I BCHQ Q
D ADDREC
D EXIT
Q
DUP ;EP -
D DUP^BCHEGR1
Q
DISP ;EP - called from protocol
D DISP^BCHEGR1
Q
PRTEF ;EP
D PRTEF^BCHEGR1
Q
DELGRP ;EP - called from protocol
NEW BCHX
S BCHX=0 F S BCHX=$O(^BCHGRPDA("AD",BCHNG,BCHX)) Q:BCHX'=+BCHX S DA=BCHX,DIK="^BCHGRPDA(" D ^DIK
S DA=BCHNG,DIK="^BCHGRPD(" D ^DIK
Q
ADDREC ;EP
D FULL^VALM1
K DIR
W !!,"Adding records for each individual patient in this group.",!
S BCHNUM=$P(^BCHGRPD(BCHNG,0),U,9) ; # SERVED
K BCHDELQ S BCHNGX=0,BCHHIT=0 F S BCHNGX=$O(^BCHGRPD(BCHNG,51,BCHNGX)) Q:BCHNGX'=+BCHNGX!($G(BCHDELQ)) D ADDREC1
K X1
SIGN1 D PAUSE,EXIT
Q
ADDREC1 ;EP
S BCHHIT=BCHHIT+1
S (DFN,BCHNRPAT)=""
S X=$P(^BCHGRPD(BCHNG,51,BCHNGX,0),U)
I X["AUPNPAT" S DFN=+X
I X["BCHRPAT" S BCHNRPAT=+X
ADDREC2 ;
S BCHG0=^BCHGRPD(BCHNG,0)
S APCDOVRR=1,BCHOVRR=1
S BCHEV("TYPE")="A"
D ^XBFMK
W !!,"Creating new record for ",$S(DFN:$P(^DPT(DFN,0),U),1:$P(^BCHRPAT(BCHNRPAT,0),U,1)),"."
;I 'DFN W !!,"Creating CHR record."
K DD,D0,DO,DIC,DA,DR S DIC(0)="EL",DIC="^BCHR(",DLAYGO=90002,DIADD=1,X=$P(^BCHGRPD(BCHNG,0),U,1)
S DIC("DR")=".02////"_$P(BCHG0,U,2)_";.03////"_$P(BCHG0,U,7)_";.04////"_$G(DFN)_";1112///"_$G(BCHNRPAT)_";.05////"_$P(BCHG0,U,10)_";.06////"_$P(BCHG0,U,5)_";.12///1"
S DIC("DR")=DIC("DR")_";.16////"_DUZ_";.17////"_DT_";.22////"_DT_";.26////H;.29///1"
S DIC("DR")=DIC("DR")_";.11////"_$S(BCHHIT=1:$P(BCHG0,U,8),1:0) ;IHS/CMI/TMJ PATCH #16 Travel time to one patient
D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
I Y=-1 W !!,$C(7),$C(7),"ERROR generating CHR record!! Deleting Record.",! D ^XBFMK Q
S BCHR=+Y
POV ;create pov records
S BCHOVRR=1
S BCHX=0 F S BCHX=$O(^BCHGRPDA("AD",BCHNG,BCHX)) Q:BCHX'=+BCHX D
.S BCHG0=^BCHGRPDA(BCHX,0)
.D ^XBFMK
.S BCHPOVM=$P(BCHG0,U,5)/BCHNUM S BCHPOVM=(BCHPOVM+.5)\1
.K DD,D0,DO,DIC,DA,DR S DIC="^BCHRPROB(",DIC(0)="EL",DLAYGO=90002.01,DIADD=1,X=$P(BCHG0,U)
.S DIC("DR")=".02////"_$G(DFN)_";.03////"_BCHR_";.04////"_$P(BCHG0,U,4)_";.05///"_BCHPOVM_";.06////"_$P(BCHG0,U,6)
.D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,DO
.I Y<0 W !!,"Creating pov record failed.!! Notify PROGRAMMER!",!!
D ^XBFMK
D GETMEAS
EDITR ;
S DIR(0)="Y",DIR("A")="Do you wish to edit anything in this record",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y D EDIT
;DO PCC LINK
;D PROTOCOL^BCHUADD1
S BCHHIT=BCHHIT+1
;update 2101 multiple
D ^XBFMK K DIADD,DLAYGO
S DIC="^BCHGRPD("_BCHNG_",61,",DIC(0)="L",DIC("P")=$P(^DD(90002.67,6101,0),U,2),DA(1)=BCHNG,X="`"_BCHR D ^DIC
I Y=-1 W !!,"adding visit to group file entry failed. Notify supervisor." H 2
D ^XBFMK K DIADD,DLAYGO
Q
GETMEAS ;
I '$G(DFN),'$G(^BCHR(BCHR,11))="" Q ;no patient 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")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
Q:'Y
S DA=BCHR,DDSFILE=90002,DR="[BCH ENTER MEASUREMENTS/TESTS" D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG D ^XBFMK Q
D ^XBFMK
Q
EDIT ;
W !
S DA=BCHR,DDSFILE=90002,DR="[BCH EDIT RECORD 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
S BCHPAT=$P(^BCHR(BCHR,0),U,4)
Q:BCHPAT=""
;backfill pt ptr in CHR POV
S BCHX=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX D
.S DIE="^BCHRPROB(",DA=BCHX,DR=".02////"_BCHPAT,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
;backfill pt ptr in CHR EDUC
;S BCHX=0 F S BCHX=$O(^BCHRPED("AD",BCHR,BCHX)) Q:BCHX'=+BCHX D
;.S DIE="^BCHRPED(",DA=BCHX,DR=".02////"_BCHPAT,DITC=""
;.D ^DIE
;.K DIE,DA,DR,DIU,DIV,DIW,DIY,DITC
;.I $D(Y) W !,"error updating educ's with patient, NOTIFY PROGRAMMER" H 5
;.Q
Q
EXIT ;EP - clean up and exit
D TERM^VALM0
S VALMBCK="R"
D GATHER
S VALMCNT=BCHLINE
D HDR
EOJ ;
K BCHV,BCHF,BCHDR,DFN,BCHR,BCHQUIT,BCHRDEL,BCHV,BCHVDLT,BCHNAME,BCHPTSV,BCHX,DFN,BCHERROR,BCHR0,BCHPNP,BCHGRPX
K BCHC,BCHD,BCHDONE,BCHEV,BCHG,BCHG0,BCHLINE,BCHN,BCHNG,BCHNGX,BCHMUM,BCHNRPAT,BCMP,BCHPATS,BCHPOVM,BCHPROB,BCHQ,BCHR,BCHX,BCHY
K DFN
D DIRX^BCHUADD
K DIC,DR,DA,X,Y,DIU,DIU,D0,DO,DI
K BCHHIT,BCHX
K DIR,X,Y,DIC,DR,DA,D0,DO,DIZ,D
Q
PAUSE ;
S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
DEL ;
S DIK="^BCHR(",DA=BCHR D ^DIK K DA,DIK
W !,"Record deleted."
D PAUSE
Q
GETPATS ;
K BCHPATS
S X=0 F S X=$O(^BCHGRPD(BCHNG,51,X)) Q:X'=+X S BCHPATS($P(^BCHGRPD(BCHNG,51,X,0),U,1))=""
GETPATSA ;
I '$D(BCHPATS) G GETPATS1
W !!,"The following patients are currently assigned to this group:"
S BCHP=0,BCHC=0 F S BCHP=$O(BCHPATS(BCHP)) Q:BCHP="" D
.S BCHC=BCHC+1
.W !?2,BCHC,") ",$$VAL^XBDIQ1($S(BCHP["AUPNPAT":2,1:90002.11),$P(BCHP,";",1),.01)
GETPATS1 ;
D EN^DDIOL("","","!!")
K DIR
S DIR(0)="S^A:Add a Patient to the Group;D:Delete a Patient from the Group;F:Finished Entering Patients for this Group"
S DIR("A")="Which action",DIR("B")="" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G GETPATSE
I Y="F" S BCHDONE=1 G GETPATSE
S Y="FM"_Y
D @Y
G GETPATSA
GETPATSE ;
S X=0,Y="",C=0
F S X=$O(BCHPATS(X)) Q:X="" D
.S C=C+1
W !,"You entered ",C," Patient Names. Is this the total number of patients"
S DIR(0)="Y",DIR("A")="that were in the group",DIR("B")="Y" KILL DA D ^DIR KILL DIR
S BCHY=Y
I $D(DIRUT) S BCHQ="" D D:BCHQ DELGRP G:BCHQ EXIT G GETPATSE
.W !!,"You ""^""'ed out."
.S DIR(0)="S^D:DELETE the entire Group Definition and Quit;G:Go back to entering Patients",DIR("A")="What do you wish to do",DIR("B")="D" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) S BCHQ=1 Q
.I Y="D" S BCHQ=1 Q
I 'Y G GETPATSA
D SET51
Q
FMD ;
;pick one here
W !!,"The following patients are currently assigned to this group:"
S BCHP=0,BCHC=0 F S BCHP=$O(BCHPATS(BCHP)) Q:BCHP="" D
.S BCHC=BCHC+1
.W !?2,BCHC,") ",$$VAL^XBDIQ1($S(BCHP["AUPNPAT":2,1:90002.11),$P(BCHP,";",1),.01)
S DIR(0)="N^1:"_BCHC_":",DIR("A")="Which one do you want delete from the group" D ^DIR KILL DIR,DA
I $D(DIRUT) Q
I 'Y Q
S X="",C=0 F S X=$O(BCHPATS(X)) Q:X="" S C=C+1 I Y=C K BCHPATS(X)
Q
FMA ;
D GETPAT^BCHEGR2
I BCHPT S BCHPATS(BCHPT_";"_$S(BCHPTT="R":"AUPNPAT(",1:"BCHRPAT("))="" Q
Q
SET51 ;
K ^BCHGRPD(BCHNG,51)
S X="",C=0 F S X=$O(BCHPATS(X)) Q:X="" S C=C+1,^BCHGRPD(BCHNG,51,C,0)=X,^BCHGRPD(BCHNG,51,"B",X,C)=""
S ^BCHGRPD(BCHNG,51,0)="^90002.6751AV^"_C_"^"_C
S DA=BCHNG,DIE="^BCHGRPD(",DR=".09///"_C D ^DIE K DIE,DR,DA
Q
BCHEGR ; IHS/CMI/LAB - GROUP ENTRY 08 Nov 2011 3:34 PM ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;
+3 ;
START ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 DO DONE
+3 ;
DATES ;
+1 WRITE !!,"You will be presented with a list of group definitions for the"
+2 WRITE !,"CHR you select for the date range you select. You will then"
+3 WRITE !,"be able to select one of the group definitions which will be "
+4 WRITE !,"duplicated and used as a template for the group data you are "
+5 WRITE !,"about to enter.",!
+6 SET BCHPROV=""
+7 DO GETPROV^BCHUAR
+8 IF 'BCHPROV
DO DONE
QUIT
+9 KILL BCHRED,BCHRBD
+10 WRITE !,"Please enter the date range for displaying Group definitions."
+11 KILL DIR
WRITE !
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Beginning Date"
+12 DO ^DIR
IF Y<1
QUIT
SET BCHRBD=Y
+13 KILL DIR
SET DIR(0)="DO^:DT:EXP"
SET DIR("A")="Enter Ending Date"
+14 DO ^DIR
IF Y<1
QUIT
SET BCHRED=Y
+15 ;
+16 IF BCHRED<BCHRBD
Begin DoDot:1
+17 WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
End DoDot:1
GOTO DATES
+18 ;
+19 ;
+20 DO EN
DO FULL^VALM1
+21 DO DONE
+22 QUIT
DONE ;
+1 DO EN^XBVK("BCH")
+2 DO ^XBFMK
+3 DO KILL^AUPNPAT
+4 QUIT
EN ;
+1 KILL ^TMP($JOB,"BCHEGR")
+2 DO GATHER
+3 DO EN^VALM("BCH GROUP ENTRY")
+4 DO CLEAR^VALM1
+5 QUIT
GATHER ;
+1 DO GATHER^BCHEGR1
+2 QUIT
CTR(X,Y) ;EP - Center
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
HDR ; -- header code
+1 SET VALMHDR(1)="Group Entry"
+2 SET X=""
SET $EXTRACT(X,7)="Date"
SET $EXTRACT(X,16)="Group Name"
SET $EXTRACT(X,37)="CHR"
SET $EXTRACT(X,54)="# SERVED"
SET $EXTRACT(X,63)="ASSESSMENTS"
+3 SET VALMHDR(2)=X
+4 QUIT
+5 ;
INIT ;
+1 DO GATHER
+2 SET VALMCNT=BCHLINE
+3 QUIT
+4 ;lori edit
HELP ;
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
EDITDEF ;
+1 DO FULL^VALM1
+2 WRITE !!,"This action should be used to edit a group definition only. If visits have"
+3 WRITE !,"already been entered for this group, you will not be able to edit the group"
+4 WRITE !,"definition.",!
+5 DO EN^VALM2(XQORNOD(0),"OS")
+6 IF '$DATA(VALMY)
WRITE !,"No records selected."
DO EXIT
QUIT
+7 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
DO EXIT
QUIT
+8 SET BCHNG=0
SET BCHNG=^TMP($JOB,"BCHEGR","IDX",R,R)
+9 IF '$DATA(^BCHGRPD(BCHNG,0))
WRITE !,"Not a valid GROUP."
KILL BCHNG,R,BCHG,R1
DO PAUSE
DO EXIT
QUIT
+10 DO FULL^VALM1
+11 IF $ORDER(^BCHGRPD(BCHNG,61,0))
WRITE !!,"This group already has visits created. You must use the REVIEW/EDIT",!,"GROUP VISITS to modify visits within this group."
DO PAUSE
DO EXIT
QUIT
+12 IF $PIECE(^BCHGRPD(BCHNG,0),U,18)
WRITE !!,"This Group's Notes have been signed. You cannot edit the Group.",!
DO PAUSE
DO EXIT
QUIT
+13 SET BCHDATE=$PIECE($PIECE(^BCHGRPD(BCHNG,0),U),".")
+14 DO EDITGRP
+15 QUIT
ADDGRP ;
+1 DO FULL^VALM1
+2 ;add new group
+3 KILL DIR
SET DIR(0)="D^:"_DT_":EP"
SET DIR("A")="Enter Date of the Group Activity"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
WRITE !,"date not entered."
DO PAUSE
DO EXIT
QUIT
+5 SET BCHDATE=Y
+6 SET X=BCHDATE
SET DIC="^BCHGRPD("
SET DLAYGO=90002.67
SET DIADD=1
SET DIC(0)="L"
SET DIC("DR")=".07////"_BCHPROV_";.04////"_DT_";.12////"_DUZ
KILL DD,DO
DO FILE^DICN
+7 IF Y=-1
WRITE !!,"entry of new group failed."
KILL DIADD,DLAYGO
DO ^XBFMK
DO EXIT
QUIT
+8 SET BCHNG=+Y
+9 KILL DIADD,DLAYGO
DO ^XBFMK
EDITGRP ;EP
+1 SET APCDOVRR=1
+2 SET DA=BCHNG
SET DDSFILE=90002.67
SET DR="[BCH EDIT GROUP DEFINITION]"
DO ^DDS
+3 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET BCHQUIT=1
KILL DIMSG
DO PAUSE
DO EXIT
QUIT
+4 ;must have a pov/provider
+5 SET E=0
+6 IF $PIECE(^BCHGRPD(BCHNG,0),U,7)=""
WRITE !!,"Group must have CHR defined."
SET E=1
+7 NEW X,G,C
+8 IF '$ORDER(^BCHGRPDA("AD",BCHNG,0))
WRITE !!,"Group must have at least one POV defined."
SET E=1
+9 IF E
SET BCHE=""
Begin DoDot:1
+10 SET DIR(0)="S^E:Edit the Group definition;D:Delete this Group definition;Q:to exit and edit it later without deleting the group definition"
SET DIR("A")="This group definition is not complete, do you wish to"
SET DIR("B")="E"
KILL DA
DO ^DIR
KILL DIR
+11 IF $DATA(DIRUT)
QUIT
+12 SET BCHE=Y
+13 QUIT
End DoDot:1
IF BCHE="E"
GOTO EDITGRP
IF BCHE="Q"
DO PAUSE
DO EXIT
IF BCHE="Q"
QUIT
WRITE !!,"deleting group definition."
SET DA=BCHNG
SET DIK="^BCHGRPD("
DO ^DIK
DO PAUSE
DO EXIT
QUIT
+14 ;now loop and get patients for the group
+15 DO ^XBFMK
+16 WRITE !!,"You have added the following group definition, please review it carefully",!,"before you proceed to add/update the patients in the group.",!
+17 DO DISP2^BCHEGR1
+18 SET DIR(0)="S^Y:Yes-group definition is accurate-continue to Patient List;N:No, I wish to edit the group definition;Q:I wish to QUIT and exit"
SET DIR("A")="Do you wish to continue on to add patient visits for this group"
+19 SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+20 IF $DATA(DIRUT)
DO PAUSE
DO EXIT
QUIT
+21 IF Y="Q"
DO DELGRP
DO PAUSE
DO EXIT
QUIT
+22 IF Y="N"
GOTO EDITGRP
SENS ;check for sensitive patients
+1 KILL BCHPAT
+2 WRITE !!!
+3 WRITE !,"You will be prompted to confirm the list of patients who were in the"
+4 WRITE !,$$VAL^XBDIQ1(90002.67,BCHNG,.03)," group on ",$$VAL^XBDIQ1(90002.67,BCHNG,.01),".",!
+5 SET BCHQ=""
+6 DO GETPATS
+7 IF BCHQ
QUIT
+8 DO ADDREC
+9 DO EXIT
+10 QUIT
DUP ;EP -
+1 DO DUP^BCHEGR1
+2 QUIT
DISP ;EP - called from protocol
+1 DO DISP^BCHEGR1
+2 QUIT
PRTEF ;EP
+1 DO PRTEF^BCHEGR1
+2 QUIT
DELGRP ;EP - called from protocol
+1 NEW BCHX
+2 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHGRPDA("AD",BCHNG,BCHX))
IF BCHX'=+BCHX
QUIT
SET DA=BCHX
SET DIK="^BCHGRPDA("
DO ^DIK
+3 SET DA=BCHNG
SET DIK="^BCHGRPD("
DO ^DIK
+4 QUIT
ADDREC ;EP
+1 DO FULL^VALM1
+2 KILL DIR
+3 WRITE !!,"Adding records for each individual patient in this group.",!
+4 ; # SERVED
SET BCHNUM=$PIECE(^BCHGRPD(BCHNG,0),U,9)
+5 KILL BCHDELQ
SET BCHNGX=0
SET BCHHIT=0
FOR
SET BCHNGX=$ORDER(^BCHGRPD(BCHNG,51,BCHNGX))
IF BCHNGX'=+BCHNGX!($GET(BCHDELQ))
QUIT
DO ADDREC1
+6 KILL X1
SIGN1 DO PAUSE
DO EXIT
+1 QUIT
ADDREC1 ;EP
+1 SET BCHHIT=BCHHIT+1
+2 SET (DFN,BCHNRPAT)=""
+3 SET X=$PIECE(^BCHGRPD(BCHNG,51,BCHNGX,0),U)
+4 IF X["AUPNPAT"
SET DFN=+X
+5 IF X["BCHRPAT"
SET BCHNRPAT=+X
ADDREC2 ;
+1 SET BCHG0=^BCHGRPD(BCHNG,0)
+2 SET APCDOVRR=1
SET BCHOVRR=1
+3 SET BCHEV("TYPE")="A"
+4 DO ^XBFMK
+5 WRITE !!,"Creating new record for ",$SELECT(DFN:$PIECE(^DPT(DFN,0),U),1:$PIECE(^BCHRPAT(BCHNRPAT,0),U,1)),"."
+6 ;I 'DFN W !!,"Creating CHR record."
+7 KILL DD,D0,DO,DIC,DA,DR
SET DIC(0)="EL"
SET DIC="^BCHR("
SET DLAYGO=90002
SET DIADD=1
SET X=$PIECE(^BCHGRPD(BCHNG,0),U,1)
+8 SET DIC("DR")=".02////"_$PIECE(BCHG0,U,2)_";.03////"_$PIECE(BCHG0,U,7)_";.04////"_$GET(DFN)_";1112///"_$GET(BCHNRPAT)_";.05////"_$PIECE(BCHG0,U,10)_";.06////"_$PIECE(BCHG0,U,5)_";.12///1"
+9 SET DIC("DR")=DIC("DR")_";.16////"_DUZ_";.17////"_DT_";.22////"_DT_";.26////H;.29///1"
+10 ;IHS/CMI/TMJ PATCH #16 Travel time to one patient
SET DIC("DR")=DIC("DR")_";.11////"_$SELECT(BCHHIT=1:$PIECE(BCHG0,U,8),1:0)
+11 DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0
+12 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"ERROR generating CHR record!! Deleting Record.",!
DO ^XBFMK
QUIT
+13 SET BCHR=+Y
POV ;create pov records
+1 SET BCHOVRR=1
+2 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHGRPDA("AD",BCHNG,BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+3 SET BCHG0=^BCHGRPDA(BCHX,0)
+4 DO ^XBFMK
+5 SET BCHPOVM=$PIECE(BCHG0,U,5)/BCHNUM
SET BCHPOVM=(BCHPOVM+.5)\1
+6 KILL DD,D0,DO,DIC,DA,DR
SET DIC="^BCHRPROB("
SET DIC(0)="EL"
SET DLAYGO=90002.01
SET DIADD=1
SET X=$PIECE(BCHG0,U)
+7 SET DIC("DR")=".02////"_$GET(DFN)_";.03////"_BCHR_";.04////"_$PIECE(BCHG0,U,4)_";.05///"_BCHPOVM_";.06////"_$PIECE(BCHG0,U,6)
+8 DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,DO
+9 IF Y<0
WRITE !!,"Creating pov record failed.!! Notify PROGRAMMER!",!!
End DoDot:1
+10 DO ^XBFMK
+11 DO GETMEAS
EDITR ;
+1 SET DIR(0)="Y"
SET DIR("A")="Do you wish to edit anything in this record"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF Y
DO EDIT
+3 ;DO PCC LINK
+4 ;D PROTOCOL^BCHUADD1
+5 SET BCHHIT=BCHHIT+1
+6 ;update 2101 multiple
+7 DO ^XBFMK
KILL DIADD,DLAYGO
+8 SET DIC="^BCHGRPD("_BCHNG_",61,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(90002.67,6101,0),U,2)
SET DA(1)=BCHNG
SET X="`"_BCHR
DO ^DIC
+9 IF Y=-1
WRITE !!,"adding visit to group file entry failed. Notify supervisor."
HANG 2
+10 DO ^XBFMK
KILL DIADD,DLAYGO
+11 QUIT
GETMEAS ;
+1 ;no patient so no measurements
IF '$GET(DFN)
IF '$GET(^BCHR(BCHR,11))=""
QUIT
+2 WRITE !
+3 SET DIR(0)="Y"
SET DIR("A")=$SELECT('$GET(BCHUABFO):"Any MEASUREMENTS, TESTS or REPRODUCTIVE FACTORS",1:"Any MEASUREMENTS/TESTS")
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF $DATA(DIRUT)
QUIT
+5 IF 'Y
QUIT
+6 SET DA=BCHR
SET DDSFILE=90002
SET DR="[BCH ENTER MEASUREMENTS/TESTS"
DO ^DDS
+7 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET BCHQUIT=1
KILL DIMSG
DO ^XBFMK
QUIT
+8 DO ^XBFMK
+9 QUIT
EDIT ;
+1 WRITE !
+2 SET DA=BCHR
SET DDSFILE=90002
SET DR="[BCH EDIT RECORD DATA]"
DO ^DDS
+3 KILL DR,DA,DDSFILE,DIC,DIE
+4 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET BCHQUIT=1
KILL DIMSG
QUIT
+5 SET BCHPAT=$PIECE(^BCHR(BCHR,0),U,4)
+6 IF BCHPAT=""
QUIT
+7 ;backfill pt ptr in CHR POV
+8 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHRPROB("AD",BCHR,BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+9 SET DIE="^BCHRPROB("
SET DA=BCHX
SET DR=".02////"_BCHPAT
SET DITC=""
+10 DO ^DIE
+11 KILL DIE,DA,DR,DIU,DIV,DIW,DIY,DITC
+12 IF $DATA(Y)
WRITE !,"error updating pov's with patient, NOTIFY PROGRAMMER"
HANG 5
+13 QUIT
End DoDot:1
+14 ;backfill pt ptr in CHR EDUC
+15 ;S BCHX=0 F S BCHX=$O(^BCHRPED("AD",BCHR,BCHX)) Q:BCHX'=+BCHX D
+16 ;.S DIE="^BCHRPED(",DA=BCHX,DR=".02////"_BCHPAT,DITC=""
+17 ;.D ^DIE
+18 ;.K DIE,DA,DR,DIU,DIV,DIW,DIY,DITC
+19 ;.I $D(Y) W !,"error updating educ's with patient, NOTIFY PROGRAMMER" H 5
+20 ;.Q
+21 QUIT
EXIT ;EP - clean up and exit
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO GATHER
+4 SET VALMCNT=BCHLINE
+5 DO HDR
EOJ ;
+1 KILL BCHV,BCHF,BCHDR,DFN,BCHR,BCHQUIT,BCHRDEL,BCHV,BCHVDLT,BCHNAME,BCHPTSV,BCHX,DFN,BCHERROR,BCHR0,BCHPNP,BCHGRPX
+2 KILL BCHC,BCHD,BCHDONE,BCHEV,BCHG,BCHG0,BCHLINE,BCHN,BCHNG,BCHNGX,BCHMUM,BCHNRPAT,BCMP,BCHPATS,BCHPOVM,BCHPROB,BCHQ,BCHR,BCHX,BCHY
+3 KILL DFN
+4 DO DIRX^BCHUADD
+5 KILL DIC,DR,DA,X,Y,DIU,DIU,D0,DO,DI
+6 KILL BCHHIT,BCHX
+7 KILL DIR,X,Y,DIC,DR,DA,D0,DO,DIZ,D
+8 QUIT
PAUSE ;
+1 SET DIR(0)="EO"
SET DIR("A")="Press enter to continue...."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 QUIT
DEL ;
+1 SET DIK="^BCHR("
SET DA=BCHR
DO ^DIK
KILL DA,DIK
+2 WRITE !,"Record deleted."
+3 DO PAUSE
+4 QUIT
GETPATS ;
+1 KILL BCHPATS
+2 SET X=0
FOR
SET X=$ORDER(^BCHGRPD(BCHNG,51,X))
IF X'=+X
QUIT
SET BCHPATS($PIECE(^BCHGRPD(BCHNG,51,X,0),U,1))=""
GETPATSA ;
+1 IF '$DATA(BCHPATS)
GOTO GETPATS1
+2 WRITE !!,"The following patients are currently assigned to this group:"
+3 SET BCHP=0
SET BCHC=0
FOR
SET BCHP=$ORDER(BCHPATS(BCHP))
IF BCHP=""
QUIT
Begin DoDot:1
+4 SET BCHC=BCHC+1
+5 WRITE !?2,BCHC,") ",$$VAL^XBDIQ1($SELECT(BCHP["AUPNPAT":2,1:90002.11),$PIECE(BCHP,";",1),.01)
End DoDot:1
GETPATS1 ;
+1 DO EN^DDIOL("","","!!")
+2 KILL DIR
+3 SET DIR(0)="S^A:Add a Patient to the Group;D:Delete a Patient from the Group;F:Finished Entering Patients for this Group"
+4 SET DIR("A")="Which action"
SET DIR("B")=""
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
GOTO GETPATSE
+6 IF Y="F"
SET BCHDONE=1
GOTO GETPATSE
+7 SET Y="FM"_Y
+8 DO @Y
+9 GOTO GETPATSA
GETPATSE ;
+1 SET X=0
SET Y=""
SET C=0
+2 FOR
SET X=$ORDER(BCHPATS(X))
IF X=""
QUIT
Begin DoDot:1
+3 SET C=C+1
End DoDot:1
+4 WRITE !,"You entered ",C," Patient Names. Is this the total number of patients"
+5 SET DIR(0)="Y"
SET DIR("A")="that were in the group"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+6 SET BCHY=Y
+7 IF $DATA(DIRUT)
SET BCHQ=""
Begin DoDot:1
+8 WRITE !!,"You ""^""'ed out."
+9 SET DIR(0)="S^D:DELETE the entire Group Definition and Quit;G:Go back to entering Patients"
SET DIR("A")="What do you wish to do"
SET DIR("B")="D"
KILL DA
DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
SET BCHQ=1
QUIT
+11 IF Y="D"
SET BCHQ=1
QUIT
End DoDot:1
IF BCHQ
DO DELGRP
IF BCHQ
GOTO EXIT
GOTO GETPATSE
+12 IF 'Y
GOTO GETPATSA
+13 DO SET51
+14 QUIT
FMD ;
+1 ;pick one here
+2 WRITE !!,"The following patients are currently assigned to this group:"
+3 SET BCHP=0
SET BCHC=0
FOR
SET BCHP=$ORDER(BCHPATS(BCHP))
IF BCHP=""
QUIT
Begin DoDot:1
+4 SET BCHC=BCHC+1
+5 WRITE !?2,BCHC,") ",$$VAL^XBDIQ1($SELECT(BCHP["AUPNPAT":2,1:90002.11),$PIECE(BCHP,";",1),.01)
End DoDot:1
+6 SET DIR(0)="N^1:"_BCHC_":"
SET DIR("A")="Which one do you want delete from the group"
DO ^DIR
KILL DIR,DA
+7 IF $DATA(DIRUT)
QUIT
+8 IF 'Y
QUIT
+9 SET X=""
SET C=0
FOR
SET X=$ORDER(BCHPATS(X))
IF X=""
QUIT
SET C=C+1
IF Y=C
KILL BCHPATS(X)
+10 QUIT
FMA ;
+1 DO GETPAT^BCHEGR2
+2 IF BCHPT
SET BCHPATS(BCHPT_";"_$SELECT(BCHPTT="R":"AUPNPAT(",1:"BCHRPAT("))=""
QUIT
+3 QUIT
SET51 ;
+1 KILL ^BCHGRPD(BCHNG,51)
+2 SET X=""
SET C=0
FOR
SET X=$ORDER(BCHPATS(X))
IF X=""
QUIT
SET C=C+1
SET ^BCHGRPD(BCHNG,51,C,0)=X
SET ^BCHGRPD(BCHNG,51,"B",X,C)=""
+3 SET ^BCHGRPD(BCHNG,51,0)="^90002.6751AV^"_C_"^"_C
+4 SET DA=BCHNG
SET DIE="^BCHGRPD("
SET DR=".09///"_C
DO ^DIE
KILL DIE,DR,DA
+5 QUIT
